fgen.fs (8133B) - raw
1 \ Function code generation 2 ?f<< /lib/arena.fs 3 ?f<< /comp/c/tok.fs 4 ?f<< /comp/c/func.fs 5 ?f<< /comp/c/egen.fs 6 7 : _err ( -- ) tokdbg abort" fgen error" ; 8 : _assert ( f -- ) not if _err then ; 9 10 : _postlude 11 _curfunc CDecl :argssize ?dup if ps+, then 12 _locvars CDecl :size ?dup if align4 rs+, then 13 popret, ; 14 15 $40 const MAXSWITCHCASES 16 \ breaks are a list of forward jumps addr that need to be resolved at the end 17 \ of the "breakeable" structure. 18 MAXSWITCHCASES Stack :new structbind Stack _breaks 19 : resolvebreaks ( tgtlvl -- ) begin ( tgt ) 20 _breaks :count over > while _breaks :pop [compile] then repeat drop ; 21 10 Stack :new structbind Stack _conts 22 : resolvecontinues ( tgtlvl -- ) begin ( tgt ) 23 _conts :count over > while _conts :pop [compile] then repeat drop ; 24 25 alias noop parseStatement ( tok -- ) \ forward declaration 26 27 : parseStatements ( -- ) 28 begin '}' readChar? not while parseStatement repeat ; 29 30 : emitRet ( eop -- ) ExprOp :>W$ expr$ _postlude exit, ; 31 : emitNullRet ( -- ) _postlude drop, exit, ; 32 : _return \ empty returns are allowed 33 ';' readChar? not if parseExpression emitRet read; else emitNullRet then ; 34 35 : _if 36 read( nextt parseExpression ExprOp :?>W$ read) expr$ 37 0 i) compare, 0 Z) branchC, 38 nextt parseStatement 39 nextt dup S" else" s= if ( jump_addr tok ) 40 drop [compile] else nextt parseStatement 41 else to nexttputback then ( jump_addr ) 42 [compile] then ; 43 44 : _for 45 _breaks :count >r _conts :count >r 46 \ initialization 47 read( ';' readChar? not if parseExpression ExprOp :release read; then 48 here nextt parseExpression ExprOp :?>W$ read; 49 expr$ 0 i) compare, 0 Z) branchC, 0 branch, ( caddr cjmpz cjmp ) \ control 50 rot here ')' readChar? not if ( cjmpz cjmp caddr aaddr ) 51 parseExpression ExprOp :release read) then 52 swap [compile] again ( cjmpz cjmp aaddr ) \ adjustment 53 swap [compile] then nextt parseStatement ( cjmpz aaddr ) 54 r> resolvecontinues 55 [compile] again [compile] then r> resolvebreaks ; 56 57 : _pspush 58 read( nextt parseExpression ExprOp :>W$ psneutral dup, read) read; ; 59 60 : _break [compile] ahead _breaks :push read; ; 61 62 : _continue [compile] ahead _conts :push read; ; 63 64 : _while 65 _breaks :count >r _conts :count >r 66 here read( nextt parseExpression read) 67 ExprOp :?>W$ expr$ 0 i) compare, 0 Z) branchC, 68 nextt parseStatement ( tgt jmp ) 69 r> resolvecontinues 70 swap [compile] again [compile] then r> resolvebreaks ; 71 72 : _do 73 _breaks :count >r _conts :count >r 74 here nextt parseStatement ( tgt ) 75 r> resolvecontinues 76 nextt S" while" s= _assert 77 read( nextt parseExpression read) 78 ExprOp :?>W$ expr$ 0 i) compare, NZ) branchC, drop 79 read; r> resolvebreaks ; 80 81 code _lookup ( nref lookup -- ) 82 A) &) !, A) @, 83 -8 rs+, RSP) 4 +) !, 0 i) @, RSP) !, begin \ RS+0=i RS+4=totcnt 84 RSP) @, RSP) 4 +) compare, 0 NZ) branchC, \ not found 85 8 rs+, nip, exit, then 86 1 RSP) +n, CELLSZ A) &) +n, A) @, 87 PSP) compare, NZ) branchC, drop \ Z=match 88 \ we have a match, add totcnt*CELLSZ to A, dereference. that's our target. 89 RSP) 4 +) @, 2 i) <<, RSP) !, A) &) @!, RSP) +, W) @, \ W=target 90 12 rs+, A) &) !, nip, branchA, 91 92 \ Switch works by constructing a lookup table of all the cases and generating 93 \ all statements one after the other. Whenever there's a "case", we associate it 94 \ to "here". Then, we evaluate the switch query and check in the lookup. Those 95 \ lookup tables live in _litarena. 96 \ However, this is tricky. We don't know beforehand how many cases we have for 97 \ our lookup table. To palliate to this, we add a level of indirection. We 98 \ generate our switch code so that it fetches its pointer to a lookup table at 99 \ a specific literal. It's only when we're done generating the case code that 100 \ we generate the lookup table and place a pointer to it at that placeholder. 101 MAXSWITCHCASES << Stack :new structbind Stack _cases 102 : _switch 103 _breaks :count >r \ V1=breakcnt 104 read( nextt parseExpression read) 105 ExprOp :?>W$ dup, CELLSZ _litarena :allot dup m) @, >r \ V2='lookup 106 pushret, compile _lookup popret, [compile] ahead >r \ V3=defjump 107 nextt '{' expectChar nextt begin ( tok ) 108 dup '}' isChar? not while ( tok ) 109 dup S" default" s= not while ( tok ) 110 dup S" case" s= if 111 drop nextt parseExpression ExprOp :const# _cases :push here _cases :push 112 nextt ':' expectChar ( ) 113 else parseStatement then ( ) nextt repeat ( tok ) \ default 114 r> ( defjump ) [compile] then nextt ':' expectChar parseStatements 115 else ( tok ) r> ( defjump ) [compile] then then ( tok ) drop 116 _cases :count 1+ CELLSZ * _litarena :[ 117 _cases :count >> dup , begin ( totcnt ) 118 _cases :count while 119 _cases :pop over CELLSZ * here + ! _cases :pop , repeat ( totcnt ) 120 CELLSZ * allot _litarena :] r> ( 'lookup ) ! r> ( breakcnt ) resolvebreaks ; 121 122 10 stringlist statementnames 123 "{" "return" "if" "for" "pspush" "break" "continue" "while" "do" "switch" 124 10 wordtbl statementhandler ( -- ) 125 'w parseStatements 'w _return 'w _if 'w _for 126 'w _pspush 'w _break 'w _continue 'w _while 127 'w _do 'w _switch 128 129 0 value _laststmtid 130 :realias parseStatement ( tok -- ) 131 dup statementnames sfind dup >r dup 0< if ( tok -1 ) \ V1=stmtidx 132 drop parseExpression ExprOp :release expr$ read; 133 else nip statementhandler swap wexec then 134 r> to _laststmtid ; 135 136 \ When there's variable initialization code, it has to come before the prelude 137 \ and we jump to it after we've created the stack frame. 138 0 value _initcode 139 140 : _, ( sz -- ) case 1 = of c, endof 2 = of 16b , endof drop , endcase ; 141 : writeStack ( stack sz -- ) >r \ V1=sz 142 bi Stack :buf( | Stack :count for ( a ) @+ V1 _, next drop rdrop ; 143 144 \ array is a Stack 145 : _copyArray ( array cdecl -- ) 146 dup CDecl :typesize >r >r \ V1=sz V2=cdecl 147 dup Stack :count V1 * tuck ( arraysz stack arraysz ) 148 _litarena :[ V1 writeStack _litarena :] ( arraysz a ) 149 litn r> dup, CDecl :halop @, litn compile move rdrop ; 150 151 : parseDeclLine ( type -- ) 152 parseDeclarator ( cdecl ) 153 dup _locvars ?dup if CDecl :append else to _locvars then begin ( cdecl ) 154 '=' readChar? if ( cdecl ) 155 _initcode not if here# to _initcode then 156 nextt parseExpression ( cdecl eop ) 157 dup ExprOp :isarray? if ExprOp arg over _copyArray else 158 ExprOp :>W$ dup ExprOp :cdecl ExprOp :hal# !, then 159 expr$ nextt then ( cdecl tok ) 160 dup ';' isChar? not while ( cdecl tok ) 161 ',' expectChar CDecl type parseDeclarator ( cdecl ) 162 dup _locvars CDecl :append repeat ( cdecl tok ) 2drop ; 163 164 \ Given a cdecl for a function body that has a proper offset field, but that 165 \ hasn't been added to the symbol list yet, check if we have a prototype in the 166 \ symbols that correspond to this function. If yes, update the jump of that 167 \ prototype. 168 : ?updateFunctionPrototype ( cdecl -- ) 169 dup CDecl name findSymbol ?dup if 170 dup CDecl :funcsig? over CDecl :incomplete? and if ( cdecl found ) 171 CDecl offset to@! here >r ( cdecl ) 172 dup CDecl offset branch, drop r> to here ( cdecl ) 173 else drop then then ( cdecl ) drop ; 174 175 \ '{' is already parsed 176 : parseFunctionBody ( cdecl -- ) 177 0 to _locvars 0 to _initcode to _curfunc ( ) 178 STORAGE_RS to@! curstorage >r 179 begin nextt dup parseType while ( tok type ) nip parseDeclLine repeat ( tok ) 180 to nexttputback r> to curstorage 181 _initcode if [compile] ahead >r then 182 _curfunc CDecl :static? not if sysdict _curfunc CDecl name entry then ( ) 183 here# _curfunc to CDecl offset ( ) 184 _curfunc ?updateFunctionPrototype _curfunc addSymbol 185 \ prelude: space for stack frame. "dup," is wiggle room for W 186 pushret, dup, _locvars CDecl :size ?dup if align4 neg rs+, then 187 _initcode ?dup if [compile] again r> [compile] then then 188 0 to _laststmtid parseStatements 189 _laststmtid 1 <> if emitNullRet then \ emit implicit return if needed 190 0 to _curfunc ; 191 192 : parseFunctionProto ( cdecl tok -- ) 193 ';' expectChar dup addSymbol curstatic if 194 dup CDecl :incomplete! here ['] _err branch, drop 195 \ allot a little extra space in case the replacement jump is wider 196 CELLSZ allot 197 else dup CDecl name sysdict @ find ?dup not if 198 CDecl name stype abort" not found" then then ( cdecl addr ) 199 swap to CDecl offset ;