egen.fs (10702B) - raw
1 \ Expression code generation 2 require /sys/scratch.fs 3 ?f<< /comp/c/tok.fs 4 ?f<< /comp/c/glob.fs 5 ?f<< /comp/c/expr.fs 6 ?f<< /comp/c/func.fs 7 ?f<< /comp/c/ptype.fs 8 9 : _err ( -- ) tokdbg abort" egen error" ; 10 : _assert ( f -- ) not if _err then ; 11 12 \ This arena is for *runtime* string and array literals. We use an arena rather 13 \ than writing directly to here because at the time when we want to write the 14 \ literal, we might be in the middle of code generation. This arena, which is 15 \ never resetted, gives us a safe space to write literals. The idea is that at 16 \ the prelude of each function, we call :reserve to ensure that we won't 17 \ allocate a new arena in the middle of the function (this might fail if a 18 \ single function allocates more than ARENASZ bytes of literals). 19 Arena :new structbind Arena _litarena 20 : egenreserve _litarena :reserve ; 21 22 \ Maximum size in bytes that a single literal can have 23 $400 const MAXLITSZ 24 25 \ parseExpression forward declaration is in glob.fs, it's needed in ptype.fs 26 alias noop parseFactor ( tok -- eop ) \ forward declaration 27 28 : unaryop doer ' , ' , does> ( eop 'op -- eop ) 29 over ExprOp :isconst? if 30 CELLSZ + @ over ExprOp arg swap execute over to ExprOp arg 31 else @ over ExprOp :?>W execute then ( eop ) ; 32 unaryop _neg, -W, neg 33 : _ -1 i) ^, ; 34 unaryop _not, _ ^ 35 : _ 0 i) compare, Z) C>W, ; 36 unaryop _!, _ not 37 38 : _&, ExprOp :& ; 39 : _*, ExprOp :* ; 40 41 : _ ( eop incsz -- eop ) 42 over ExprOp :*arisz * 43 over ExprOp :isW? if i) +, else over ExprOp :hal# +n, then ; 44 : _++, 1 _ ; : _--, -1 _ ; 45 46 UOPSCNT wordtbl uoptbl ( eop -- eop ) 47 'w _neg, 'w _not, 'w _!, 'w _&, 'w _*, 'w _++, 'w _--, 48 49 \ For binops to resolve without problems, we want both operands to solve without 50 \ affecting PS so that HAL ops generated for one operand isn't invalidated when 51 \ the second pushes to PS. Hence the :?freeCurrentW prelude. 52 53 \ ops that can freely swap their operands 54 : _prep ( left right -- left halop ) 55 dup ExprOp :hasW? if swap then over ExprOp :?>W ExprOp :hal$ ; 56 : _*, _prep *, ; : _&, _prep &, ; : _^, _prep ^, ; : _|, _prep |, ; 57 : _&&, _prep 0 i) compare, 0 Z) branchC, 58 swap @, 0 i) compare, [compile] then NZ) C>W, ; 59 : _||, _prep |, 0 i) compare, NZ) C>W, ; 60 61 : _arimul ( left right -- left right*n ) 62 over ExprOp :*arisz over ExprOp :*arisz <> if 63 over ExprOp :*arisz 1 = if swap then \ left has mutiplier 64 over ExprOp :*arisz over ExprOp :*n ( left right*arisz ) then ; 65 66 \ TODO: generalize CDecl hamonization (:copymeta below) 67 : _+, ( left right -- eop ) 68 over rot> _arimul _prep +, tuck ExprOp :copymeta ; 69 70 \ ops that can't freely swap their operands 71 : _prep ( left right -- left halop ) 72 ExprOp :?freeCurrentW over ExprOp :?>W ExprOp :hal$ ; 73 : _/, _prep /mod, ; : _%, _prep /mod, A) &) @, ; 74 : _<<, _prep <<, ; : _>>, _prep >>, ; 75 76 : _ptr-, ( left right -- eop ) 77 _prep -, CELLSZ over ExprOp :/n dup ExprOp :toint ; 78 : _-, ( left right -- eop ) 79 over ExprOp :*arisz over ExprOp :*arisz tuck = swap CELLSZ = and if 80 _ptr-, else _arimul _prep -, then ; 81 82 : _prep ( left right -- eop halop ) 83 ExprOp :?freeCurrentW ExprOp :?>W$ dup ExprOp :hal# <>) ; 84 : _=, _prep @, ; : _-=, _prep -, ; 85 : _*=, _prep *, ; : _/=, _prep /mod, ; : _%=, _prep dup /mod, A>) @, ; 86 : _&=, _prep &, ; : _^=, _prep ^, ; : _|=, _prep |, ; 87 : _<<=, _prep <<, ; : _>>=, _prep >>, ; 88 89 : _+=, 90 over ExprOp :*arisz dup 1 > if over ExprOp :*n else drop then 91 _prep +, ; 92 93 \ To avoid W juggling, we check if our right operand is W. If it is, no need 94 \ for juggling, all we need is to invert the condition we use. 95 \ data: unsigned cond, unsigned swapped cond, signed cond, signed swapped cond 96 : cmpop doer 4 for ' execute , next does> ( left right 'conds ) 97 over ExprOp :unsigned? not if CELLSZ << + then 98 over ExprOp :isW? if CELLSZ + @ >r swap else @ >r then ( left right ) 99 ExprOp :?freeCurrentW over ExprOp :?>W ExprOp :hal$ compare, r> C>W, ; 100 cmpop _==, Z) Z) Z) Z) cmpop _!=, NZ) NZ) NZ) NZ) 101 cmpop _<, <) >=) s<) s>=) cmpop _<=, <=) >) s<=) s>) 102 cmpop _>, >) <=) s>) s<=) cmpop _>=, >=) <) s>=) s<) 103 104 : _?, ( left right -- eop ) 105 nextt ':' expectChar nextt parseExpression ( cond trueres falseres ) 106 swap ExprOp :?>W ExprOp :?freeCurrentW ( cond falseres ) 107 swap ExprOp :>W$ PS- 0 i) compare, 0 Z) branchC, 108 drop, [compile] else nip, over ExprOp :>W [compile] then ; 109 110 BOPSCNT wordtbl boptbl ( left right -- eop ) 111 'w _+, 'w _-, 'w _*, 'w _/, 'w _%, 'w _<<, 'w _>>, 'w _<, 112 'w _>, 'w _<=, 'w _>=, 'w _==, 'w _!=, 'w _&, 'w _^, 'w _|, 113 'w _&&, 'w _||, 'w _=, 'w _+=, 'w _-=, 'w _*=, 'w _/=, 'w _%=, 114 'w _<<=, 'w _>>=, 'w _&=, 'w _^=, 'w _|=, 'w _?, 115 116 \ we gave to call "res" after having parsed its arguments. "(" is parsed. 117 \ Arguments construction: basically, we can place arguments on PS in the order 118 \ in which we parse them. Convenient. However, parseExpression can "leak" to 119 \ psoff, which means that while we construct our list, we need to keep track of 120 \ the expected psoff. If it's higher, we need to readjust. After the call, we 121 \ need to restore psoff to its initial level *without actually adjusting* 122 \ because it's the callee's responsibility to free its arguments. 123 code _callA branchA, 124 : _funcall ( eop -- eop ) 125 ExprOp :?freeCurrentW 126 psoff dup >r >r \ V1=psinitlvl V2=pslvl 127 ')' readChar? not if begin ( funcres tok ) 128 parseExpression ExprOp :?>W 129 psoff V2 - ?dup if dup ps+, neg to+ psoff then CELLSZ to+ V2 130 ',' readChar? while nextt repeat ')' expectChar then ( funcres ) 131 dup ExprOp cdecl dup CDecl :constfuncsig? if ( funcres cdecl ) 132 nip dup CDecl offset branchR, 133 else swap ExprOp :hal$ A>) @, ['] _callA branchR, then ( cdecl ) 134 rdrop r> ( psinitlvl ) to psoff 135 ExprOp currentW ?dup if PS- ExprOp :release then 136 \ TODO: arilvl of fun rettype isn't properly preserved here 137 CDecl :rettype if PS+ ExprOp :W else ExprOp :none then ; 138 139 : _arrow ( eop -- eop ) 140 dup ExprOp cdecl nextt ( eop cdecl name ) 141 swap CDecl type CDecl :find# tuck CDecl offset ( field-cdecl eop offset ) 142 over ExprOp :?>W i) +, ( field-cdecl eop ) tuck ExprOp :cdecl! 143 dup ExprOp cdecl CDecl :reference? not if 144 dup to1+ ExprOp lvl ExprOp :* then ; 145 146 \ parses, if possible, a postfix operator. If none, this is a noop. 147 \ We parse postfix args as long as there are any. 148 : parsePostfixOp ( eop -- eop ) 149 nextt case ( ) 150 '[' isChar? of \ x[y] is the equivalent of *(x+y) 151 nextt parseExpression _+, 152 dup ExprOp cdecl CDecl :structdot? not if ExprOp :* then 153 nextt ']' expectChar parsePostfixOp endof 154 '(' isChar? of _funcall parsePostfixOp endof 155 S" ->" s= of 156 dup ExprOp cdecl CDecl :structarrow? _assert 157 _arrow parsePostfixOp endof 158 '.' isChar? of 159 dup ExprOp cdecl CDecl :structdot? _assert 160 _arrow parsePostfixOp endof 161 S" ++" s= of 1 over ExprOp :incdec endof 162 S" --" s= of -1 over ExprOp :incdec endof 163 to nexttputback 164 endcase ; 165 166 \ We need to parse the entire list before we begin writing to _litarena if we 167 \ want to support the possibility that some of these elements use _litarena 168 \ themselves (for example, string literals). *then*, we write. 169 MAXLITSZ Stack :new structbind Stack _list 170 : parseList ( -- eop ) 171 _list :empty begin ( ) 172 nextt parseFactor dup ExprOp type case ( eop ) 173 ExprOp CONST = of ExprOp :const# endof 174 ExprOp CDECL = of 175 ExprOp cdecl dup CDecl :isglobal? _assert CDecl offset endof 176 _err endcase ( n ) _list :push 177 ',' readChar? not until ( tok ) 178 '}' expectChar _list :self ExprOp ARRAY ExprOp :new ; 179 180 \ A factor can be: 181 \ 1. A constant 182 \ 2. A lvalue 183 \ 3. A unaryop/postfixop containing a factor 184 \ 4. A function call 185 \ 5. An expression inside () parens. 186 \ 6. A string literal 187 \ 7. pspop() 188 \ 8. a typecast followed by a factor 189 \ 9. NULL 190 \ 10. sizeof() 191 :realias parseFactor ( tok -- eop ) case ( ) 192 '(' isChar? of 193 \ can be an expression or a typecast 194 nextt dup parseType if ( tok type ) 195 nip parseDeclarator read) nextt parseFactor ( type eop ) 196 tuck ExprOp :typecast 197 else ( tok ) parseExpression read) parsePostfixOp then 198 endof 199 '"' isChar? of MAXLITSZ _litarena :[ 200 here 0 c, 201 ['] ccin ['] in< realias ," ['] consolein ['] in< realias 202 ccin dup '0' = if 203 drop 1+ 0 c, \ null terminated 204 else ccputback here over - 1- over c! then ( saddr ) 205 _litarena :] drop ( "a ) ExprOp :const endof 206 '{' isChar? of parseList endof 207 S" pspop" s= of 208 read( read) ExprOp :?freeCurrentW 209 0 PSP+) @, PS+ ExprOp :W parsePostfixOp endof 210 S" NULL" s= of 0 ExprOp :const endof 211 S" sizeof" s= of 212 read( nextt parseType _assert typesize ExprOp :const read) endof 213 uopid of ( opid ) 214 nextt parseFactor ( opid eop ) uoptbl rot wexec endof 215 isIdent? of \ lvalue, FunCall or macro 216 r@ findIdent ?dup _assert ExprOp :cdecl parsePostfixOp endof 217 parse if ExprOp :const else _err then 218 endcase ; 219 220 : bothconst? ( left right -- f ) ExprOp :isconst? swap ExprOp :isconst? and ; 221 222 : ?constApply ( left right opid -- left right opid 0 | eop 1 ) >r \ V1=opid 223 2dup bothconst? if r@ applyConstBinop 1 else ( left right ) 224 dup ExprOp :isone? r@ neutralbyrone? and if drop 1 else 225 over ExprOp :isone? r@ neutralbyone? and if nip 1 else 226 dup ExprOp :iszero? r@ nulledbyzero? and if nip 1 else 227 over ExprOp :iszero? r@ nulledbyzero? and if drop 1 else 228 dup ExprOp :iszero? r@ neutralbyrzero? and if drop 1 else 229 over ExprOp :iszero? r@ neutralbyzero? and if nip 1 else 0 then 230 then then then then then then ( left right opid 0 | eop 1 ) 231 dup if rdrop else r> swap then ; 232 233 : applyBinop ( left right opid -- eop ) 234 ?constApply not if boptbl swap wexec then ; 235 236 \ Parse the "right" part of an expression with the leftmost factor and leftmost 237 \ binary operator already parsed. 238 : parseRExpr ( left binop -- eop ) >r >r \ V1=binop V2=left 239 nextt parseFactor nextt ( right tok ) 240 dup bopid if ( right tok opright ) 241 \ another binop! let's apply precedence rules. 242 nip V1 bopprec over bopprec ( right opright lprec rprec ) > if 243 \ the right part has more precedence. 244 parseRExpr ( newright ) r> swap r> ( left right opid ) applyBinop 245 else ( right opright ) \ the left part has more precedence 246 swap r> swap r> ( opright left right opid ) applyBinop ( opr newleft ) 247 swap parseRExpr then 248 else ( right tok ) to nexttputback r> swap r> applyBinop then ; 249 250 \ An expression can be 2 things: 251 \ 1. a factor 252 \ 2. A binaryop containing two expressions. 253 :realias parseExpression ( tok -- eop ) 254 \ first tok is always a factor 255 parseFactor nextt ( left tok ) 256 dup bopid if ( left tok binop ) 257 nip parseRExpr else to nexttputback then ;