commit f3e8faf244c41fe6dcf6d5bfcbaae8e6d71fa145
parent 13900fdb77d1ae7457dd39463ac7cb5a0f664672
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 1 Apr 2023 22:14:22 -0400
halcc: cleanup old units
I won't need to salvage anything from them any more. Final LOC count: 1338
Diffstat:
7 files changed, 4 insertions(+), 1220 deletions(-)
diff --git a/fs/comp/c/pgen.fs b/fs/comp/c/pgen.fs
@@ -1,522 +0,0 @@
-\ C compiler parse+generate
-\ This CC used to build an AST in memory and then, in a subsequent phase,
-\ generate the corresponding code. It turned out to be needlessly complex. In
-\ this unit, we are fed with tokens, we parse it, then we spit code directly.
-require /sys/scratch.fs
-?f<< /lib/str.fs
-?f<< /lib/wordtbl.fs
-?f<< /lib/stack.fs
-?f<< /lib/arena.fs
-?f<< /comp/c/tok.fs
-?f<< /comp/c/type.fs
-\ This unit also requires vm/(ARCH).fs, but it's loaded in comp/c/cc.fs
-
-\ This arena is for *runtime* string and array literals. We use an arena rather
-\ than writing directly to here because at the time when we want to write the
-\ literal, we might be in the middle of code generation. This arena, which is
-\ never resetted, gives us a safe space to write literals. The idea is that at
-\ the prelude of each function, we call :reserve to ensure that we won't
-\ allocate a new arena in the middle of the function (this might fail if a
-\ single function allocates more than ARENASZ bytes of literals).
-Arena :new structbind Arena _litarena
-
-\ Maximum number that a function call can have
-$10 const MAXARGCNT
-\ Maximum size in bytes that a single literal can have
-$400 const MAXLITSZ
-
-0 value _ccdebug
-: _err ( -- ) tokdbg abort" pgen error" ;
-: _assert ( f -- ) not if _err then ;
-: spit ( a u -- ) swap >r for
- i 40 mod not if nl> then
- 8b to@+ V1 .x1 next rdrop ;
-
-\ Unary operators
-7 const UOPSCNT
-UOPSCNT stringlist UOPTlist "-" "~" "!" "&" "*" "++" "--"
-3 const UOP&
-4 const UOP*
-
-: uopid ( tok -- opid? f )
- UOPTlist sfind dup 0< if drop 0 else 1 then ;
-: uoptoken ( opid -- tok ) UOPTlist slistiter ;
-
-UOPSCNT wordtbl uopgentbl ( -- )
-:w ( - ) vmneg, ;
-:w ( ~ ) vmnot, ;
-:w ( ! ) vmboolnot, ;
-:w ( & ) vmop :&op ;
-:w ( * ) vmop :*op ;
-:w ( ++ ) vm++op, ;
-:w ( -- ) vm--op, ;
-
-\ Postfix operators
-2 const POPSCNT
-POPSCNT stringlist POPTlist "++" "--"
-
-POPSCNT wordtbl popgentbl ( -- )
-:w ( ++ ) vmop++, ;
-:w ( -- ) vmop--, ;
-
-: popid ( tok -- opid? f )
- POPTlist sfind dup 0< if drop 0 else 1 then ;
-: poptoken ( opid -- tok ) POPTlist slistiter ;
-
-\ Binary operators
-31 const BOPSCNT
-BOPSCNT stringlist BOPTlist
- "+" "-" "*" "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "&" "^" "|"
- "&&" "||" "=" "+=" "-=" "*=" "/=" "%=" "<<=" ">>=" "&=" "^=" "|=" "?" ":"
-
-\ binary ops precedence. lower means more precedence
-create bopsprectbl BOPSCNT nc,
- 1 1 0 0 0 2 2 3 3 3 3 4 4 5 5 5
- 6 6 7 7 7 7 7 7 7 7 7 7 7 8 9
-
-MAXARGCNT Stack :new structbind Stack _stack?:
-: _? vmop :push _stack?: :push selop^ ;
-: _: _stack?: :pop vm?:, ;
-
-BOPSCNT wordtbl bopgentbl ( -- )
-'w vm+, 'w vm-, 'w vm*, 'w vm/,
-'w vm%, 'w vm<<, 'w vm>>, 'w vm<,
-'w vm>, 'w vm<=, 'w vm>=, 'w vm==,
-'w vm!=, 'w vm&, 'w vm^, 'w vm|,
-'w vm&&, 'w vm||, 'w vm=, 'w vm+=,
-'w vm-=, 'w vm*=, 'w vm/=, 'w vm%=,
-'w vm<<=, 'w vm>>=, 'w vm&=, 'w vm^=,
-'w vm|=, 'w _? 'w _:
-
-\ Constant expressions have a reduced set of operators so that they don't
-\ conflict with some syntax where they're used (namely, inside a "case xxx:")
-0 value _isconstexpr
-: bopid ( tok -- opid? f )
- BOPTlist sfind dup 0< if drop 0
- else dup 17 > _isconstexpr and if drop 0 else 1 then then ;
-: bopprec ( opid -- precedence ) BOPSCNT min bopsprectbl + c@ ;
-: boptoken ( opid -- tok ) BOPTlist slistiter ;
-: ptrbop? ( opid -- f ) 2 < ; \ can op be applied to pointers?
-
-0 value _curfunc \ ctype of the current function (includes arguments)
-0 value _locvars \ the root ctype of local variables for current function
-
-: findIdent ( name -- ctype-or-0 )
- _curfunc if dup _curfunc CType :find ?dup if nip exit then then ( name )
- dup _locvars if to' _locvars CType :find else drop 0 then ( name ctype-or-0 )
- ?dup if nip else findSymbol then ;
-
-alias _err parseType ( tok -- type? f ) \ forward declaration
-alias _err parseDeclarator ( type -- ctype ) \ forward declaration
-alias noop parseExpression ( tok -- ) \ forward declaration
-
-\ Parsing strategy: we dig down recursively through nextt until we get to our
-\ identifier. Before that identifier, we can hit chars like ( and *.
-\ For *, it's easy, we inc our current indirection level. For (, we enter a
-\ recursion.
-\ After we hit the identifier, we continue parsing forward, where
-\ we can hit chars like [, an array specifier and (, a function specifier. We
-\ process them, amending our ctype structure as we go. If we hit a ), we go up
-\ one level in recursion and apply previously recorded indirection levels to the
-\ returned type.
-
-: _arg ( parent-ctype tok -- offset )
- parseType _assert parseDeclarator ( ctype newtype )
- tuck swap to CType nexttype ( newtype )
- ')' readChar? if 0 swap CType :offset! else
- ',' expectChar dup nextt _arg ( ctype offset )
- swap CType :offset! then ( offset ) ;
-
-: parseConstExpr ( tok -- n )
- 1 to _isconstexpr parseExpression 0 to _isconstexpr
- vmop^ :noop# vmop :isconst# vmop arg ops$ ;
-
-\ parsing after the identifier
-: _post ( ctype -- ctype )
- begin ( ctype ) nextt case
- '[' of isChar?^
- nextt parseConstExpr nextt ']' expectChar ( ctype nbelem )
- over to CType nbelem endof
- '(' of isChar?^
- dup CType :funcsig! STORAGE_PS to@! curstorage >r
- ')' readChar? not if ( ctype tok )
- over swap _arg ( ctype offset ) drop then
- r> to curstorage endof
- r> to nexttputback exit
- endcase again ;
-
-: _addlvl ( lvl type -- type ) tuck type*lvl + dup 4 < _assert swap type*lvl! ;
-
-: _parseDeclarator ( type -- ctype )
- 0 begin ( type lvl )
- '*' readChar? while ( type lvl tok ) 1+ repeat ( type lvl tok )
- dup '(' isChar? if ( type lvl tok )
- drop swap parseDeclarator read)
- >r >r \ V1=outer-ctype v2=inner-lvl
- \ type recursion in C is "inside out". The ctype we have now is the outer
- \ type. We'll forward its current "type" field to the ctype we're about to
- \ finish parsing, and that new ctype will be placed in our outer type's
- \ "type" field. One thing we have to be careful about is to keep our *lvl
- \ where it belongs.
- V1 CType type dup type*lvl ( inner-type outer-lvl )
- swap r> ( inner-lvl ) swap type*lvl! ( outer-lvl inner-type )
- NULLSTR swap CType :new _post ( outer-lvl inner-type )
- _addlvl ( inner-type ) r@ ( outer-type ) to CType type r> ( ctype )
- else ( type lvl tok )
- dup isIdent? not if to nexttputback NULLSTR then ( type lvl name )
- rot CType :new ( lvl ctype )
- _post tuck CType type ( ctype lvl type )
- _addlvl ( ctype type )
- over to CType type ( ctype ) then ;
-current ' parseDeclarator realias
-
-: _parseStruct ( -- ctype )
- nextt dup isIdent? if nextt else NULLSTR swap then
- '{' expectChar ( name ) TYPE_VOID CType :new ( res )
- dup CType :struct! dup addTypedef
- 0 >r dup begin ( res prev ) \ V1=offset
- '}' readChar? not while ( res prev tok )
- parseType _assert parseDeclarator begin ( res prev new )
- tuck swap to CType nexttype ( res new )
- V1 over to CType offset
- dup typesize to+ V1
- ';' readChar? not while ( res prev tok )
- ',' expectChar dup CType type parseDeclarator repeat ( res prev )
- repeat ( res prev ) rdrop drop ;
-
-\ parse a type from stream, starting with "tok". This only parses the "type"
-\ part without the "*" part or the name part. The result can be a "base" type
-\ (type < $100) or a CType if the type is a struct, union or enum.
-: _parseType ( tok -- type? f )
- dup S" typedef" s= if
- drop nextt parseType _assert parseDeclarator ( ctype )
- dup addTypedef 1 exit then
- dup S" struct" s= if drop _parseStruct 1 else
- dup S" unsigned" s= if drop $10 nextt else $00 swap then ( type tok )
- dup typenames sfind dup 0>= if ( type tok idx )
- nip << << or 1
- else drop nip findTypedef ( type-or-0 ) ?dup bool then then ;
-current ' parseType realias
-
-alias noop parseFactor ( tok -- ) \ forward declaration
-
-\ we have a func call and its target in in vmop
-: _funcall ( -- )
- vmop type ctype? _assert
- \ We either have a direct function signature or a pointer to it.
- \ TODO: :funcptr? doesn't work correctly here. fix this
- vmop type ctype'
- dup CType :funcsig? not if CType type ctype' then
- dup CType :funcsig? _assert CType type ( type )
- ')' readChar? if 0 else ( type tok )
- to nexttputback vmop :push >r \ V1=callop
- MAXARGCNT CELLSZ * Stack SZ +
- \ TODO: I had a strange failure if, instead of using the result of :new
- \ below, I used the result of :]. They're supposed to be equivalent, but :]
- \ was wrong. investigate.
- syspad :[ MAXARGCNT Stack :new syspad :] drop >r ( type ) \ V2=args
- begin ( type )
- nextt parseExpression vmop :push V2 Stack :push ( type )
- ',' readChar? not until ( type tok )
- ')' expectChar
- \ now, we want to push the args to PS in the reverse order, with first
- \ arg on top of PS.
- V2 Stack :count dup >r for V2 Stack :pop next ( type argN .. arg0 )
- r> rdrop r> vmop :pop ( type argN .. arg0 nargs ) then ( type ... narg )
- vmcall, ( type ) if vmpspop, then ;
-
-: _arrow ( -- ) \ struct in vmop
- nextt vmop type dup ctype? _assert dup type*lvl 1 = _assert ( name type )
- ctype' dup CType :struct? _assert ( name ctype )
- CType :find# ( field-ctype )
- dup CType offset vmop :+n vmop :*op ( field-ctype )
- dup CType type to vmop type
- CType nbelem if vmop :&op then ;
-
-\ parses, if possible, a postfix operator. If none, this is a noop.
-\ We parse postfix args as long as there are any.
-: parsePostfixOp ( -- )
- nextt case ( )
- '[' of isChar?^ \ x[y] is the equivalent of *(x+y)
- vmop^ :push vmop :push
- nextt parseExpression selop^ vmop :pop vm+, vmop :*op vmop^ :pop
- nextt ']' expectChar parsePostfixOp endof
- '(' of isChar?^ _funcall parsePostfixOp endof
- S" ->" of s= _arrow parsePostfixOp endof
- '.' of isChar?^ vmop :&op _arrow parsePostfixOp endof
- of popid ( opid )
- popgentbl swap wexec parsePostfixOp endof
- r@ to nexttputback
- endcase ;
-
-\ We need to parse the entire list before we begin writing to _litarena if we
-\ want to support the possibility that some of these elements use _litarena
-\ themselves (for example, string literals). *then*, we write.
-MAXLITSZ Stack :new structbind Stack _list
-: _, ( sz -- ) case 1 of = c, endof 2 of = 16b , endof , endcase ;
-: parseList ( typesize -- ) >r \ V1=typesize
- _list :empty begin ( )
- nextt parseFactor vmop :isconst# vmop arg _list :push vmop :init
- ',' readChar? not until ( tok )
- '}' expectChar _list :count V1 * dup CELLSZ + _litarena :[ ( listsize )
- , _list :buf( _list :count for ( a ) @+ V1 _, next ( a ) drop
- _litarena :] constarray>op rdrop ;
-
-\ A factor can be:
-\ 1. A constant
-\ 2. A lvalue
-\ 3. A unaryop/postfixop containing a factor
-\ 4. A function call
-\ 5. An expression inside () parens.
-\ 6. A string literal
-\ 7. pspop()
-\ 8. a typecast followed by a factor
-\ 9. NULL
-\ 10. sizeof()
-: _ ( tok -- ) vmop :init case ( )
- '(' of isChar?^
- \ can be an expression or a typecast
- nextt dup parseType if ( tok type )
- \ TODO: actually process the typecast
- nip parseDeclarator read) nextt parseFactor vmop :typecast
- else ( tok ) parseExpression read) parsePostfixOp then
- endof
- '"' of isChar?^ MAXLITSZ _litarena :[
- here 0 c, ['] ," with-stdin<
- ccin dup '0' = if
- drop 1+ 0 c, \ null terminated
- else ccputback here over - 1- over c! then ( saddr )
- _litarena :] drop const>op endof
- '{' of isChar?^ \ vmop^ must be set to target for list
- vmop^ :hasop# vmop^ type *ariunitsz parseList endof
- S" pspop" of s= read( read) vmpspop, parsePostfixOp endof
- S" NULL" of s= 0 const>op endof
- S" sizeof" of s= read( nextt parseType _assert typesize const>op read) endof
- of uopid ( opid )
- nextt parseFactor ( opid ) \ vmop is set
- uopgentbl swap wexec endof
- of isIdent? \ lvalue, FunCall or macro
- r@ findIdent ?dup _assert ctype>op parsePostfixOp endof
- r@ parse if const>op else _err then
- endcase ;
-current ' parseFactor realias
-
-\ Parse the "right" part of an expression with the leftmost factor and leftmost
-\ binary operator already parsed. We expect vmop to already contain the left
-\ factor.
-: parseRExpr ( binop -- )
- nextt selop^ parseFactor nextt ( binop tok )
- \ left factor in vmop^ right factor in vmop
- dup bopid if ( opleft tok opright )
- \ another binop! let's apply precedence rules.
- nip over bopprec over bopprec ( l r lprec rprec ) > if ( l r )
- \ the right part has more precedence.
- vmop^ :push ( l r op ) swap parseRExpr vmop^ :pop ( binop )
- \ vmop has rexpr result, vmop^ has left operator
- else ( l r ) \ the left part has more precedence
- selop^ swap bopgentbl swap wexec ( r )
- \ vmop has result, vmop^ is empty
- parseRExpr ( ) exit then ( binop )
- else ( opleft tok ) to nexttputback then ( binop )
- \ left factor in vmop^ right factor in vmop
- selop^ bopgentbl swap wexec ;
-
-\ An expression can be 2 things:
-\ 1. a factor
-\ 3. A binaryop containing two expressions.
-: _ ( tok -- ) \ parseExpression
- \ first tok is always a factor
- parseFactor nextt ( tok ) \ factor in vmop
- dup bopid if ( tok binop )
- nip vmop^ :push swap parseRExpr vmop^ :pop
- else to nexttputback then ;
-
-current ' parseExpression realias
-
-$40 const MAXSWITCHCASES
-\ breaks are a list of forward jumps addr that need to be resolved at the end
-\ of the "breakeable" structure.
-MAXSWITCHCASES Stack :new structbind Stack _breaks
-: resolvebreaks ( tgtlvl -- )
- begin ( tgt ) _breaks :count over > while _breaks :pop ]vmjmp repeat drop ;
-10 Stack :new structbind Stack _conts
-: resolvecontinues ( tgtlvl -- )
- begin ( tgt ) _conts :count over > while _conts :pop ]vmjmp repeat drop ;
-
-alias noop parseStatement ( tok -- ) \ forward declaration
-
-: parseStatements ( -- )
- begin '}' readChar? not while parseStatement repeat ;
-
-: _return \ empty returns are allowed
- ';' readChar? not if parseExpression read; then vmret, ops$ ;
-
-: _if
- read( nextt parseExpression read) vmjz[, ops$
- nextt parseStatement ops$
- nextt dup S" else" s= if ( jump_addr tok )
- drop vmjmp[, swap ]vmjmp nextt parseStatement ops$
- else to nexttputback then ( jump_addr )
- ]vmjmp ;
-
-: _for
- _breaks :count >r _conts :count >r
- read( ';' readChar? not if parseExpression ops$ read; then \ initialization
- here nextt parseExpression read; vmjz[, vmjmp[, ( caddr cjmpz cjmp ) \ control
- rot here ')' readChar? not if ( cjmpz cjmp caddr aaddr )
- parseExpression ops$ read) then
- swap vmjmp, ( cjmpz cjmp aaddr ) \ adjustment
- swap ]vmjmp nextt parseStatement ( cjmpz aaddr )
- r> resolvecontinues
- vmjmp, ]vmjmp r> resolvebreaks ;
-
-: _pspush read( nextt parseExpression vmpspush, read) read; ;
-
-: _break vmjmp[, _breaks :push read; ;
-
-: _continue vmjmp[, _conts :push read; ;
-
-: _while
- _breaks :count >r _conts :count >r
- here read( nextt parseExpression read)
- vmjz[, ops$ nextt parseStatement ( wjmp waddr )
- r> resolvecontinues
- swap vmjmp, ]vmjmp r> resolvebreaks ;
-
-: _do
- _breaks :count >r _conts :count >r
- here nextt parseStatement ( daddr )
- r> resolvecontinues
- nextt S" while" s= _assert
- read( nextt parseExpression read) ( daddr )
- vmjnz, read; r> resolvebreaks ;
-
-\ Switch works by constructing a lookup table of all the cases and generating
-\ all statements one after the other. Whenever there's a "case", we associate it
-\ to "here". Then, we evaluate the switch query and check in the lookup. Those
-\ lookup tables live in _litarena.
-\ However, this is tricky. We don't know beforehand how many cases we have for
-\ our lookup table. To palliate to this, we add a level of indirection. We
-\ generate our switch code so that it fetches its pointer to a lookup table at
-\ a specific literal. It's only when we're done generating the case code that
-\ we generate the lookup table and place a pointer to it at that placeholder.
-MAXSWITCHCASES << Stack :new structbind Stack _cases
-: _switch
- _breaks :count >r \ V1=breakcnt
- read( nextt parseExpression read)
- CELLSZ _litarena :allot dup vmswitch, >r \ V2='lookup
- vmjmp[, >r \ V3=defjump
- nextt '{' expectChar nextt begin ( tok )
- dup '}' isChar? not while ( tok )
- dup S" default" s= not while ( tok )
- dup S" case" s= if
- drop nextt parseConstExpr _cases :push here _cases :push
- nextt ':' expectChar ( )
- else parseStatement then ( ) nextt repeat ( tok ) \ default
- r> ( defjump ) ]vmjmp nextt ':' expectChar parseStatements else ( tok ) \ }
- r> ( defjump ) ]vmjmp then ( tok ) drop
- _cases :count 1+ CELLSZ * _litarena :[
- _cases :count >> dup , begin ( totcnt )
- _cases :count while
- _cases :pop over CELLSZ * here + ! _cases :pop , repeat ( totcnt )
- CELLSZ * allot _litarena :] r> ( 'lookup ) ! r> ( breakcnt ) resolvebreaks ;
-
-10 stringlist statementnames
- "{" "return" "if" "for" "pspush" "break" "continue" "while" "do" "switch"
-10 wordtbl statementhandler ( -- )
-'w parseStatements 'w _return 'w _if 'w _for
-'w _pspush 'w _break 'w _continue 'w _while
-'w _do 'w _switch
-
-0 value _laststmtid
-: _ ( tok -- ) \ parseStatement
- dup statementnames sfind dup >r dup 0< if ( tok -1 ) \ V1=stmtidx
- drop parseExpression read; else nip statementhandler swap wexec then
- ops$ r> to _laststmtid ;
-current ' parseStatement realias
-
-\ When there's variable initialization code, it has to come before the prelude
-\ and we jump to it after we've created the stack frame.
-0 value _initcode
-
-: parseDeclLine ( type -- )
- parseDeclarator ( ctype )
- dup _locvars ?dup if CType :append else to _locvars then begin ( ctype )
- '=' readChar? if ( ctype )
- _initcode not if here to _initcode then
- dup ctype>op selop^ nextt parseExpression
- selop^ vm=, ops$ nextt then ( ctype tok )
- dup ';' isChar? not while ( ctype tok )
- ',' expectChar CType type parseDeclarator ( ctype )
- dup _locvars CType :append repeat ( ctype tok ) 2drop ;
-
-\ Given a ctype for a function body that has a proper offset field, but that
-\ hasn't been added to the symbol list yet, check if we have a prototype in the
-\ symbols that correspond to this function. If yes, update the jump of that
-\ prototype.
-: ?updateFunctionPrototype ( ctype -- )
- dup CType name findSymbol ?dup if
- dup CType :funcsig? over CType :incomplete? and if ( ctype found )
- CType offset to@! here >r ( ctype )
- dup CType offset vmjmp, r> to here ( ctype )
- else drop then then ( ctype ) drop ;
-
-\ '{' is already parsed
-: parseFunctionBody ( ctype -- )
- 0 to _locvars 0 to _initcode to _curfunc _litarena :reserve ( )
- STORAGE_SF to@! curstorage >r
- begin nextt dup parseType while ( tok type ) nip parseDeclLine repeat ( tok )
- to nexttputback r> to curstorage
- _initcode if vmjmp[, >r then
- _curfunc CType :static? not if sysdict _curfunc CType name entry then ( )
- here _curfunc to CType offset ( )
- _curfunc ?updateFunctionPrototype _curfunc addSymbol
- _curfunc CType :argssize _locvars CType :size vmprelude, ( )
- _initcode ?dup if vmjmp, r> ]vmjmp then
- 0 to _laststmtid parseStatements
- _laststmtid 1 <> if vmret, then \ emit implicit return if needed
- 0 to _curfunc ;
-
-: parseFunctionProto ( ctype tok -- )
- ';' expectChar dup addSymbol curstatic if
- dup CType :incomplete! here ['] _err vmjmp,
- \ allot a little extra space in case the replacement jump is wider
- CELLSZ allot
- else dup CType name sysdict @ find ?dup not if
- CType name stype abort" not found" then then ( ctype addr )
- swap to CType offset ;
-
-: parseGlobalDecl ( ctype -- )
- dup addSymbol
- dup CType :static? not if \ not static
- dup CType name NEXTWORD ! create then ( ctype )
- here over to CType offset ( ctype )
- '=' readChar? if ( ctype )
- dup ctype>op selop^ nextt parseExpression vmop loc case ( ctype )
- VM_CONSTANT of = vmop arg , endof
- VM_CONSTARRAY of = vmop arg @+ move, endof
- _err endcase ops$
- else to nexttputback dup CType :size allot then ( ctype )
- ',' readChar? if
- CType type parseDeclarator parseGlobalDecl
- else ';' expectChar drop then ;
-
-\ Begin parsing incoming tokens for a new "element" (a function or a
-\ declaration) and consume tokens until that element is finished parsing. That
-\ element is written to memory at "here".
-: cparse ( tok -- )
- cctypereserve 0 to curstatic
- dup S" static" s= if drop nextt 1 to curstatic then
- parseType _assert ( type )
- ';' readChar? if \ Only a type on a line is fine, carry on
- drop exit then to nexttputback
- parseDeclarator ( ctype )
- curstatic if dup CType :static! then
- _ccdebug if ." parsing: " dup printtype nl> then
- dup CType :funcsig? if ( ctype )
- '{' readChar? if dup parseFunctionBody
- _ccdebug if
- ." complete: " dup printtype nl> CType offset here over - spit nl>
- else drop then
- else parseFunctionProto then
- else parseGlobalDecl then ( ) ;
diff --git a/fs/comp/c/vm/commonhi.fs b/fs/comp/c/vm/commonhi.fs
@@ -1,90 +0,0 @@
-\ Code common to all VM implementations (high part)
-?f<< /lib/wordtbl.fs
-
-: ops$ vmop :init vmop^ :init neutral# ;
-
-: bothconst? vmop :foldable? vmop^ :foldable? and ;
-
-struct+[ VMOp
- : :*n over _assert over 1 <> if
- dup :isconst? if tuck arg * swap to arg else VMOp :*n then
- else 2drop then ;
- : :/n over _assert over 1 <> if
- dup :isconst? if tuck arg swap / swap to arg else VMOp :/n then
- else 2drop then ;
- : :+n over if dup :isconst? if to+ arg else VMOp :+n then else 2drop then ;
- : :&n dup :isconst? if tuck arg and swap to arg else VMOp :&n then ;
-
- : :typecast ( type self -- )
- 2dup to type swap typesize case ( self )
- 1 of = $ff swap :&n endof
- 2 of = $ffff swap :&n endof
- drop
- endcase ;
-]struct
-
-UNOPCNT wordtbl constops ( n -- n )
-'w neg 'w ^ 'w bool 'w not
-
-: unop doer , does> @ vmop :foldable? if
- vmop arg swap constops swap wexec ( n ) to vmop arg
- else unop, then ;
-0 unop vmneg, 1 unop vmnot, 2 unop vmboolify, 3 unop vmboolnot,
-
-: unopmut doer , does> @ vmop :isconst? not _assert unopmut, ;
-0 unopmut vm++op, 1 unopmut vm--op, 2 unopmut vmop++, 3 unopmut vmop--,
-
-\ perform necessary adjustments if we have pointer +/- scalar.
-: _ptrariadj ( -- )
- vmop :typeptr? vmop^ :typeptr? not and if
- vmop^ :>res vmop :*arisz vmop^ :*n then
- vmop^ :typeptr? vmop :typeptr? not and if
- vmop :>res vmop^ :*arisz vmop :*n then ;
-
-ARIOPCNT wordtbl constops ( n n -- n )
-'w + 'w - 'w * 'w /
-'w mod 'w and 'w or 'w xor
-'w lshift 'w rshift
-
-: _constbinop ( idx tbl -- )
- swap wtbl@ ( w ) vmop arg vmop^ arg rot execute ( n )
- to vmop arg vmop^ :init ;
-: _ariop, bothconst? if constops _constbinop else ariop, then ;
-: ariop doer , does> @ _ariop, ;
-2 ariop vm*, 3 ariop vm/,
-4 ariop vm%, 5 ariop vm&, 6 ariop vm|, 7 ariop vm^,
-8 ariop vm<<, 9 ariop vm>>,
-
-: vm+, _ptrariadj 0 ( + ) _ariop, ;
-
-\ vm-, is special because it handles the special "pointer-pointer" situation.
-: vm-, _ptrariadj vmop :typeptr? vmop^ :typeptr? and if
- vmop :*arisz 1 ( - ) _ariop, ( divisor ) vmop :/n
- TYPE_INT to vmop type
- else 1 ( - ) _ariop, then ;
-
-: _movarray, \ special case, we have a {1, 2, 3} assign
- vmop loc VM_STACKFRAME = _assert
- vmop^ arg vmop^ :init @+ ( a sz )
- swap litn dup, RSP) vmop arg +) lea, litn \ on compiled PS: src dst len
- compile move ;
-
-: _assignop, ( opid -- )
- vmop :isconst? not _assert
- vmop^ loc VM_CONSTARRAY = if 10 = _assert _movarray, else assignop, then ;
-: assignop doer , does> @ _assignop, ;
-2 assignop vm*=, 3 assignop vm/=,
-4 assignop vm%=, 5 assignop vm&=, 6 assignop vm|=, 7 assignop vm^=,
-8 assignop vm<<=, 9 assignop vm>>=, 10 assignop vm=,
-
-: vm+=, _ptrariadj 0 ( + ) _assignop, ;
-: vm-=, _ptrariadj 1 ( - ) _assignop, ;
-
-LOGOPCNT wordtbl constops ( n n -- n )
-'w < 'w > 'w <= 'w >=
-'w = 'w <> :w and bool ; :w or bool ;
-
-: logop doer , does> @
- bothconst? if constops _constbinop else logop, then TYPE_INT to vmop type ;
-0 logop vm<, 1 logop vm>, 2 logop vm<=, 3 logop vm>=,
-4 logop vm==, 5 logop vm!=, 6 logop vm&&, 7 logop vm||,
diff --git a/fs/comp/c/vm/commonlo.fs b/fs/comp/c/vm/commonlo.fs
@@ -1,115 +0,0 @@
-\ Code common to all VM implementations (low part)
-
-\ Note: there can only be one implementation of the VM loaded in memory at once.
-\ Loading another VM impl will break the previous one. In Dusk, it's not a
-\ problem because there is no CC cross-compiling. You'll always want to compile
-\ with one VM: your CPU's.
-
-\ Relation between "loc" and type:
-\ Location is where the value is stored. We track a level of indirection here
-\ for performance reasons: CPUs generally can access locations with a level of
-\ indirection. The type contains the "logical" level of indirection of the value
-\ stored in the location. If, for example, we have a int* stored in a
-\ VM_REGISTER, it's the exact equivalent of having an int stored in a
-\ VM_*REGISTER. The number is the same.
-require /sys/scratch.fs
-?f<< /comp/c/type.fs
-
-4 const UNOPCNT \ neg not boolify boolnot
-4 const UNOPMUTCNT \ ++op --op op++ op--
-10 const ARIOPCNT \ + - * / % & | ^ << >>
-11 const ASSIGNOPCNT \ += -= *= /= %= &= |= ^= <<= >>= =
-8 const LOGOPCNT \ < > <= >= == != && ||
-
-: _err abort" vm error" ;
-: _assert not if _err then ;
-
-\ Execution context (function)
-
-0 value argsz \ size of the argument portion of the SF.
-0 value locsz \ size of the "local vars" portion of the SF.
-
-\ Operands definition and selection
-\ Locations constant: where is the op located?
-$00 const VM_NONE \ nowhere
-$01 const VM_CONSTANT \ a constant of value "arg"
-$02 const VM_STACKFRAME \ on RS at RSP+arg
-$03 const VM_ARGSFRAME \ on PS at PSP+arg
-$04 const VM_REGISTER \ in an implementation-specific register of id "arg"
-$05 const VM_CONSTARRAY \ pointer to bytes beginning with 4b size (in bytes)
-\ Below, references to a location (points to X)
-$11 const VM_*CONSTANT
-$12 const VM_*STACKFRAME
-$13 const VM_*ARGSFRAME
-$14 const VM_*REGISTER
-
-struct[ VMOp
- sfield loc \ one of the VM_ constants
- sfield arg
- sfield type \ from comp/c/type
- sfield other \ link to the "other" op
- 4 &+ 'arg
- \ Initialize op to VM_NONE, "freeing" any resource it held.
- : :init VM_NONE over to loc TYPE_INT swap to type ;
- : :loclo loc $f and ;
- \ Is loc a pointer?
- : :locptr? loc $10 and bool ;
- \ Is type a pointer?
- : :typeptr? type type*lvl bool ;
- : :isconst? loc VM_CONSTANT = ;
- : :isconstlo? :loclo VM_CONSTANT = ;
- : :foldable? dup :isconst? swap :typeptr? not and ;
- : :noop# loc VM_NONE = _assert ;
- : :hasop# loc VM_NONE <> _assert ;
- : :isconst# :isconst? _assert ;
- : :>const ( n self -- ) dup :noop# VM_CONSTANT over to loc ( n self ) to arg ;
- \ Ensure that op is a proper "result", that is, a proper destination operand
- \ that is not going to mutate its original value.
- : :>res abort" Not implemented" ;
- : :keep ( self -- 'copy ) 12 syspad :move ;
- : :push ( self -- 'copy ) dup >r :keep VM_NONE to r> loc ;
- : :pop ( 'copy self -- ) dup :noop# 12 move ;
- : :&loc dup :locptr? _assert dup :loclo swap to loc ;
- : :&op dup :&loc dup type type*lvl+ swap to type ;
- : :type- dup type type*lvl- swap to type ;
- : :*op dup loc case
- VM_CONSTANT of = endof
- VM_STACKFRAME of = endof
- VM_ARGSFRAME of = endof
- VM_REGISTER of = endof
- _err endcase
- dup loc $10 or over to loc :type- ;
- : :*arisz ( self -- n ) type *ariunitsz ;
-]struct
-
-create operands VMOp SZ 2 * allot
-operands structbind VMOp vmop
-operands VMOp SZ + structbind VMOp vmop^ \ the "other" op
-vmop^ :self to vmop other
-vmop :self to vmop^ other
-
-: _sel ['] vmop rebind vmop other ['] vmop^ rebind ;
-: selop^ vmop other _sel ;
-
-: .ops
- vmop loc .x1 spc> vmop type printtype spc> vmop arg .x spc>
- vmop^ loc .x1 spc> vmop^ type printtype spc> vmop^ arg .x nl> ;
-
-\ Managing operands
-
-: isconst# vmop :isconst? _assert ;
-: const>op ( n -- ) vmop :>const ;
-: constarray>op ( a -- ) vmop :noop# VM_CONSTARRAY to vmop loc to vmop arg ;
-: sf+>op ( off -- ) vmop :noop# VM_*STACKFRAME to vmop loc to vmop arg ;
-: ps+>op ( off -- ) vmop :noop# VM_*ARGSFRAME to vmop loc to vmop arg ;
-: mem>op ( n -- ) vmop :noop# VM_*CONSTANT to vmop loc to vmop arg ;
-: ctype>op ( ctype -- )
- vmop :noop#
- dup CType type to vmop type ( ctype )
- dup case
- of CType :funcsig? r@ to vmop type r@ CType offset const>op endof
- of CType :isglobal? r@ CType offset mem>op endof
- of CType :isarg? r@ CType offset ps+>op endof
- r@ CType offset sf+>op
- endcase
- CType nbelem if vmop :&op then ;
diff --git a/fs/comp/c/vm/forth.fs b/fs/comp/c/vm/forth.fs
@@ -1,169 +0,0 @@
-\ C compiler virtual machine for Forth targets
-
-?f<< /comp/c/vm/commonlo.fs
-?f<< /lib/wordtbl.fs
-?f<< /asm/hal.fs
-
-0 value psoff
-: PS+ CELLSZ to+ psoff ;
-: PS- CELLSZ neg to+ psoff ;
-: halsz! ( operand sz -- operand )
- case 1 of = 8b) endof 2 of = 16b) endof endcase ;
-
-struct+[ VMOp
- : _compile ( arg loc -- ) \ compile "straight" operands, errors on * ops.
- case ( arg )
- VM_CONSTANT of = litn PS+ endof
- VM_STACKFRAME of = dup, PS+ RSP) swap +) lea, endof
- VM_ARGSFRAME of = dup, PS+ PSP) swap psoff CELLSZ - + +) lea, endof
- VM_REGISTER of = dup, PS+ PSP) swap psoff CELLSZ - + +) @, endof
- _err endcase ;
- : :compile& dup :locptr? _assert bi arg | :loclo _compile ;
- \ Dereference PS TOS using this operand's type size
- : :TOS@ ( self -- ) W) swap type typesize halsz! @, ;
- \ Resolve current operand and dereferences it if needed
- : :compile ( self -- )
- bi+ arg | :locptr?
- if over :loclo _compile :TOS@ else swap loc _compile then ;
- : :compile$
- \ special case that happens often: our op is current top of stack. When we
- \ don't want to keep the op (hence the "$"), then no compiling is necessary.
- \ just do nothing. It saves a lot of bytecode.
- dup loc VM_REGISTER = over arg neg psoff = and
- not if dup :compile then :init ;
- \ "save" the value currently on PS TOS as a "register" (see doc/cc/forth)
- : :>reg VM_REGISTER over to loc psoff neg swap to arg ;
- \ dereference current operand
- : :*op dup :locptr? if dup :compile dup :>reg then VMOp :*op ;
- : :*n ( n self -- ) tuck :compile litn compile * :>reg ;
- : :/n ( n self -- ) tuck :compile litn compile / :>reg ;
- : :+n ( n self -- ) tuck :compile W+n, :>reg ;
- : :&n ( n self -- ) tuck :compile andn, :>reg ;
- : :>res dup :compile :>reg ;
-]struct
-
-: _psrewind ?dup if CELLSZ - ?dup if ps+, then drop, then ;
-\ Free elements leaked to PS during the execution of the function
-: neutral# 0 to@! psoff _psrewind ;
-
-\ generate function prelude code by allocating "locsz" bytes on RS.
-: vmprelude, ( argsz locsz -- )
- to locsz to argsz 0 to psoff
- locsz if locsz neg rs+, then ;
-
-\ deallocate locsz and argsz. If result is set, keep a 4b in here and push the
-\ result there.
-: vmret,
- vmop^ :noop# \ returning with a second operand? something's wrong
- vmop loc dup >r if vmop :compile$ PS- then
- 0 to@! psoff argsz + ?dup if
- r@ ( had loc? ) if ps+, else _psrewind then then rdrop
- locsz ?dup if rs+, then exit, ;
-
-: vmcall, ( ?argN .. ?arg0 nargs -- ) dup >r \ V1=nargs
- vmop :push >r
- for vmop :pop vmop :compile$ next
- r> vmop :pop VM_CONSTANT vmop loc = if
- vmop arg execute, vmop :init
- else vmop :compile$ compile execute PS- then
- r> ( nargs ) CELLSZ * neg to+ psoff ;
-
-\ Allocate a new register for active op and pop 4b from PS into it.
-: vmpspop, vmop :noop# PS+ vmop :>reg ;
-
-\ Push active op to PS.
-: vmpspush, vmop :compile$ PS- ;
-
-\ Jumping
-: ]vmjmp [compile] then ;
-: vmjmp, [compile] again ;
-: vmjmp[, [compile] ahead ;
-\ In conditional jumps below, the source of the test is in current op
-\ However, because we don't track "psoff" across branches, we *have* to have a
-\ neutral level before the jump, which means that this flag that we're pushing
-\ on PS *has* to be right after the last argument of the args frame.
-\ The same logic applies to vmswitch,.
-: _compileFinal
- vmop^ :noop# vmop :compile$ PS- 0 to@! psoff ?dup if ps+, then ;
-: vmjz, ( a -- ) _compileFinal [compile] until ;
-: vmjz[, ( -- a ) _compileFinal [compile] if ;
-: vmjnz, ( a -- ) _compileFinal compile not [compile] until ;
-: vmjnz[, ( -- a ) _compileFinal compile not [compile] if ;
-
-UNOPCNT wordtbl unop
-'w neg 'w ^ 'w bool 'w not
-: unop, ( opid -- ) vmop :compile$ unop swap wexec, vmop :>reg ;
-
-\ Comptime sig: incsz -- Runtime sig: -- n
-UNOPMUTCNT >> wordtbl _tbl32
-:w ( ++op/--op ) W) [+n], W) @, ;
-:w ( op++/op-- ) W>A, W) @, A) [+n], ;
-
-UNOPMUTCNT >> wordtbl _tbl16
-:w ( ++op/--op ) W) 16b) [+n], W) 16b) @, ;
-:w ( op++/op-- ) W>A, W) 16b) @, A) 16b) [+n], ;
-
-UNOPMUTCNT >> wordtbl _tbl8
-:w ( ++op/--op ) W) 8b) [+n], W) 8b) @, ;
-:w ( op++/op-- ) W>A, W) 8b) @, A) 8b) [+n], ;
-
-: unopmut, ( opid -- )
- vmop type typesize
- case 1 of = _tbl8 endof 2 of = _tbl16 endof _tbl32 endcase ( opid tbl )
- over >> wtbl@ ( opid w ) vmop :compile&
- vmop :*arisz rot 1 and if neg then swap ( incsz w ) execute vmop :>reg ;
-
-ARIOPCNT 1+ ( for = ) wordtbl _tbl
-'w + 'w - 'w * 'w /
-'w mod 'w and 'w or 'w xor
-'w lshift 'w rshift 'w nip
-
-: _binop, ( opid tbl -- )
- vmop :compile vmop^ :compile$
- swap wexec, PS- vmop :>reg ;
-
-: ariop, ( opid -- ) _tbl _binop, ;
-
-\ Copy the contents of op2 in the memory address pointed out by op1 and deinit
-\ op2. In other words, perform an assign with the right part as op2 and the left
-\ part as op1.
-\ an assignop, is like a unop in the sense that it operates directly on op1, but
-\ with the participation of op2.
-: assignop, ( opid -- )
- vmop type typesize ( opid sz ) vmop :compile& \ addr in W
- dup, PS+ W) over halsz! @, vmop^ :compile$ ( opid sz )
- swap _tbl swap wexec, PS- ( sz ) \ result on TOS
- PSP) swap halsz! [!], nip, PS- vmop :>reg ;
-
-: _s $80000000 + swap $80000000 + swap ;
-LOGOPCNT wordtbl _tblsigned
-:w _s < ; :w _s > ; :w _s <= ; :w _s >= ;
-'w = 'w <> 'w and? 'w or?
-
-LOGOPCNT wordtbl _tblunsigned
-'w < 'w > 'w <= 'w >=
-'w = 'w <> 'w and? 'w or?
-
-: logop, ( opid -- )
- vmop type typeunsigned? if _tblunsigned else _tblsigned then _binop, ;
-
-: vm?:, ( condop -- )
- vmop^ :compile$ \ false-res on TOS
- vmop^ :pop vmop^ :compile$ [compile] if PS-
- \ we're in the "true" branch. drop the false res, replace with true.
- compile drop PS- vmop :compile vmop :init
- ]vmjmp vmop :>reg ;
-
-code _lookup ( nref lookup -- )
- W>A, A) @,
- -8 rs+, RSP) 4 +) !, 0 LIT>W, RSP) !, begin \ RS+0=i RS+4=totcnt
- RSP) @, RSP) 4 +) cmp, 0 NZ) branchC, \ not found
- 8 rs+, nip, drop, exit, then
- 1 RSP) [+n], CELLSZ A+n, A) @,
- PSP) cmp, NZ) branchC, drop \ Z=match
- \ we have a match, add totcnt*CELLSZ to A, dereference. that's our target.
- RSP) 4 +) @, 2 <<n, RSP) !, W<>A, RSP) +, W) @, \ W=target
- 12 rs+, W>A, nip, drop, branchA,
-
-: vmswitch, ( 'lookup -- )
- _compileFinal litn W) @, compile _lookup ;
diff --git a/fs/comp/c/vm/i386.fs b/fs/comp/c/vm/i386.fs
@@ -1,309 +0,0 @@
-\ C compiler virtual machine for i386
-
-\ For usage example, see tests/comp/c/vm.fs
-?f<< /asm/i386.fs
-?f<< /lib/bit.fs
-?f<< /lib/wordtbl.fs
-?f<< /comp/c/vm/commonlo.fs
-
-\ Mask of registers (by their ID in asm/i386) that can be allocated as
-\ VM_REGISTER. DX is not used in the regular allot stack so that it can be used
-\ "freely" in code generation.
-$cb const USABLEREGS \ 11001011 = di si bx cx ax
-0 value regused \ a bit mask of register used.
-
-\ i386 register ID constants
-0 const AX 1 const CX 2 const DX 7 const DI
-
-: regusable? ( regid -- f ) USABLEREGS swap bit? ;
-: regused? ( regid -- f ) regused swap bit? ;
-: reguse ( regid -- )
- dup regused? not _assert
- regused swap bit1! to regused ;
-\ Allocate a free register.
-: regallot ( -- regid )
- 0 8 for ( regid )
- dup regusable? if dup regused? not if ( regid )
- dup reguse ( regid ) break then then
- 1+ next abort" TODO: support deeper expressions" then ;
-: regfree ( regid -- )
- regused over bit? not if
- .x1 spc> regused .x1 spc> abort" register allocation imbalance" then
- regused swap bit0! to regused ;
-: pushregs
- 8 for i 1- dup regused? if r) push, else drop then next ;
-: popregs
- 8 for 8 i - dup regused? if r) pop, else drop then next ;
-
-struct+[ VMOp
- : :?regfree dup :loclo VM_REGISTER = if arg regfree else drop then ;
- \ reinitialize selected op to VM_NONE and dealloc registers if needed
- : :init dup :?regfree VMOp :init ;
-
- : :dest# loc VM_CONSTANT <> _assert ;
- : :isAX? dup :loclo VM_REGISTER = swap arg AX = and ;
- : :typesz! ( opmod self -- opmod )
- type typesize case 1 of = 8b) endof 2 of = 16b) endof endcase ;
- \ Resolve current operand as an assembler "src" argument.
- : :compile ( self -- opmod )
- bi arg | loc case
- VM_CONSTANT of = i) endof
- VM_STACKFRAME of = abort" can't address VM_STACKFRAME directly" endof
- VM_REGISTER of = r) endof
- VM_*CONSTANT of = m) endof
- VM_*STACKFRAME of = sp swap d) endof
- VM_*ARGSFRAME of = bp swap d) endof
- VM_*REGISTER of = r) 0 d) endof
- abort" can't :compile location" endcase ;
- : :compilesz bi :compile | :typesz! ;
- : :compiletest
- bi :compilesz | loc VM_REGISTER = if dup test, else 0 i) cmp, then ;
-
- \ Force current operand to be copied to a register
- : _ regallot tuck r) ( rid self dst ) over :compilesz ?movzx, to arg ;
- : :>reg dup >r loc case \ V1=self
- VM_CONSTANT of = V1 _ VM_REGISTER V1 to loc endof
- VM_*CONSTANT of = V1 _ VM_REGISTER V1 to loc endof
- VM_REGISTER of = endof
- VM_*REGISTER of = endof
- VM_STACKFRAME of =
- regallot dup r) sp mov,
- V1 arg if dup r) V1 arg i) add, then ( regid )
- V1 to arg VM_REGISTER V1 to loc endof
- VM_*STACKFRAME of = V1 _ VM_REGISTER V1 to loc endof
- VM_*ARGSFRAME of = V1 _ VM_REGISTER V1 to loc endof
- _err
- endcase rdrop ;
-
- : :complex?
- dup loc VM_*REGISTER = over :loclo VM_STACKFRAME = or
- over loc VM_*ARGSFRAME = or swap loc VM_*CONSTANT = or ;
-
- \ Resolve any referencing into a "simple" operand, that is, an operand that
- \ can be combined to a "complex" operand. There are 2 options: VM_REGISTER and
- \ VM_CONSTANT. If the op isn't one of those, we transform it.
- : :>simple
- dup >r loc case \ V1=self
- VM_STACKFRAME of = V1 :>reg endof
- VM_*CONSTANT of = V1 :>reg endof
- VM_*STACKFRAME of = V1 :>reg endof
- VM_*ARGSFRAME of = V1 :>reg endof
- VM_*REGISTER of =
- V1 :compile V1 :compilesz ?movzx, VM_REGISTER V1 to loc endof
- endcase rdrop ;
-
- \ Before doing an operation on two operands, we verify that they are
- \ compatible, that is, whether we have at most one "complex" operand. if we
- \ have two complex operands, "other" is made "simple".
- : :?>simple dup :complex? if other :>simple else drop then ;
-
- \ if possible, dereference current operand
- : :*op dup loc case
- VM_*CONSTANT of = dup :>reg endof
- VM_*STACKFRAME of = dup :>reg endof
- VM_*ARGSFRAME of = dup :>reg endof
- VM_*REGISTER of = dup :>simple endof
- endcase VMOp :*op ;
-
- : :>res dup :>reg :>simple ;
-
- : :+n ( n self -- ) dup :>res :compile swap i) add, ;
- : :&n ( n self -- ) dup :>res :compile swap i) and, ;
-
-]struct
-
-\ Verify that we're in "neutral" position with regards to registers
-: neutral# regused if abort" unbalanced reg allot/free" then ;
-
-\ If one op is larger than the other, copy the smaller one to a register and
-\ copy the type of the larger op to the smaller.
-: harmonizeops vmop type typesize vmop^ type typesize 2dup < if
- 2drop vmop :>res vmop^ type to vmop type else > if
- vmop^ :>res vmop type to vmop^ type then then ;
-
-\ Jumping
-: ]vmjmp ( 'jump_addr -- ) forward! ;
-: vmjmp, ( a -- ) abs>rel jmp, ;
-: vmjmp[, ( -- a ) forward jmp, ;
-\ we take current op and test whether it's zero, setting Z. If the op is a
-\ simple register, the "test eax, eax" form is more compact. Otherwise, use
-\ test ..., -1.
-: vmtest, vmop :>reg vmop :compiletest vmop :init ;
-: vmjz, ( a -- ) vmtest, abs>rel jz, ;
-: vmjz[, ( -- a ) vmtest, forward jz, ;
-: vmjnz, ( a -- ) vmtest, abs>rel jnz, ;
-: vmjnz[, ( -- a ) vmtest, forward jnz, ;
-
-\ Code generation - Functions, calls, ret, pspush, pspop
-
-\ generate function prelude code by allocating "locsz" bytes on RS.
-: vmprelude, ( argsz locsz -- )
- to locsz to argsz
- locsz if sp locsz i) sub, then ;
-\ deallocate locsz and argsz. If result is set, keep a 4b in here and push the
-\ result there.
-: vmret,
- vmop^ :noop# \ returning with a second operand? something's wrong
- argsz vmop loc if CELLSZ - then
- vmop :>simple \ for bp 0 d) src mov, to work, "src" has to be "simple"
- locsz if sp locsz i) add, then
- ?dup if bp swap i) add, then
- vmop loc if bp 0 d) vmop :compile mov, then
- ret, ;
-
-: vmcall, ( ?argN .. ?arg0 nargs -- )
- vmop :push >r \ V1=callop
- ?dup if dup >r \ V2=nargs
- for ( ... arg )
- vmop :pop vmop :>simple
- bp V2 i - 1+ CELLSZ * neg d) vmop :compile mov, vmop :init next
- bp r> ( nargs ) CELLSZ * i) sub,
- then
- pushregs
- r> vmop :pop VM_CONSTANT vmop loc = if
- vmop arg VM_NONE to vmop loc abs>rel else vmop :compile then
- call, popregs vmop :init ;
-
-\ Allocate a new register for active op and pop 4b from PS into it.
-: vmpspop,
- vmop :noop# VM_REGISTER to vmop loc regallot dup to vmop arg r) bp 0 d) mov,
- bp CELLSZ i) add, ;
-
-\ Push active op to PS.
-: vmpspush,
- vmop :>simple bp CELLSZ i) sub, bp 0 d) vmop :compile mov, vmop :init ;
-
-\ mul and div are special and cannot use binopprep for two reasons: their target
-\ operand is hardcoded to EAX, the other operand needs to be a register and EDX
-\ gets overwritten by the operation (and, for div, it needs to be set to 0).
-struct+[ VMOp
- 0 value _restoreAX
- : :forceAX
- 0 to _restoreAX
- dup :isAX? not if
- AX regused? if
- dup other :isAX? if
- regallot dup r) ax mov, ( self regid )
- over other to arg ( self )
- else 1 to _restoreAX ax push, then
- else regallot drop then
- ax swap :compilesz ?movzx,
- else drop then ;
- : :?restoreAX dup :isAX? not if
- :compilesz ax mov, _restoreAX if ax pop, else AX regfree then
- else drop then ;
- : :*n ( n self -- )
- dup :>res dup :forceAX dx rot i) mov, dx mul, :?restoreAX ;
- : :/n ( n self -- )
- DI regused? not _assert
- dup :>res dup :forceAX dx dx xor, di rot i) mov, di div, :?restoreAX ;
-]struct
-
-: _pre vmop :forceAX vmop^ :>res ;
-: _post vmop^ :init vmop :?restoreAX ;
-: _*= _pre vmop^ :compile mul, _post ;
-: _/= _pre dx dx xor, vmop^ :compile div, _post ;
-: _%= _pre dx dx xor, vmop^ :compile div, ax dx mov, _post ;
-
-ASSIGNOPCNT wordtbl _tbl
-'w add, 'w sub, 'w _*= 'w _/=
-'w _%= 'w and, 'w or, 'w xor,
-'w shl, 'w shr, 'w mov,
-
-: _mulop? ( opid -- f ) 2 - 3 < ;
-: _mulop ( opid ) _tbl swap wexec ;
-: _shcl? ( opid -- f ) 8 - 2 < vmop^ :isconst? not and ;
-: _shcl
- CX regused? dup >r if
- dx cx mov, vmop arg CX = if DX to vmop arg then
- else CX reguse then \ V1=CX used?
- vmop^ arg CX <> if cx vmop^ :compilesz ?movzx, then
- vmop :compilesz swap ( opid ) 8 - if cl shr, else cl shl, then
- vmop^ :init r> ( CXused? ) if
- cx dx mov, vmop arg DX = if CX to vmop arg then
- else CX regfree then ;
-: ariop, ( opid -- )
- vmop :>res harmonizeops
- dup _mulop? if _mulop exit then
- dup _shcl? if _shcl exit then
- >r vmop :compilesz vmop^ :compile
- _tbl r> ( opid ) wexec vmop^ :init ;
-
-: assignop, ( opid -- )
- dup _mulop? if _mulop exit then
- dup _shcl? if _shcl exit then
- >r vmop :?>simple vmop :compilesz vmop^ :hasop# vmop^ :compile
- _tbl r> ( opid ) wexec vmop^ :init ;
-
-: _z>vmop vmop :compile 0 i) mov, vmop :compile setnz, ;
-UNOPCNT wordtbl _tbl
-'w neg, 'w not,
-:w ( boolify ) neg, _z>vmop ;
-:w ( boolnot ) neg, vmop :compile 0 i) mov, vmop :compile setz, ;
-
-: unop, ( opid -- ) >r vmop :>res vmop :compilesz _tbl r> ( opid ) wexec ;
-
-: _doit vmop :compilesz swap ( opmod n ) case
- 1 of = inc, endof
- -1 of = dec, endof
- r@ i) add, endcase ;
-: _pre ( n -- ) vmop :dest# _doit ;
-\ It's a bit complicated here. Before we inc/dec, we need a copy of the current
-\ value in a new register, which will be our result.
-: _post ( n -- )
- regallot dup r) vmop :compilesz ?movzx, ( n regid )
- swap _doit vmop :?regfree ( regid ) to vmop arg VM_REGISTER to vmop loc ;
-UNOPMUTCNT wordtbl _tbl
-:w ( ++op ) _pre ;
-:w ( --op ) neg _pre ;
-:w ( op++ ) _post ;
-:w ( op-- ) neg _post ;
-
-: unopmut, ( opid -- ) >r vmop :*arisz _tbl r> ( opid ) wexec ;
-
-: _
- vmop :>res vmop :compilesz vmop^ :compile cmp, vmop^ :init
- vmop :compile 0 i) mov, vmop :compile ;
-: _&& vmop :>reg vmop :compilesz vmop :compile test, forward8 jz,
- \ TODO: The :>reg below is a quick hack to go through cases where vmop^ is a
- \ const. If we do proper constant propagation at the AST level, this should
- \ never happen and :>reg becomes spurious.
- vmop^ :>reg vmop^ :compiletest vmop^ :init forward! _z>vmop ;
-: _|| vmop :>reg vmop :compile vmop^ :compile or, vmop^ :init
- vmop :compile neg, _z>vmop ;
-
-LOGOPCNT wordtbl _tblsigned
-:w _ setl, ; :w _ setg, ; :w _ setle, ; :w _ setge, ;
-:w _ setz, ; :w _ setnz, ; 'w _&& 'w _||
-
-LOGOPCNT wordtbl _tblunsigned
-:w _ setb, ; :w _ seta, ; :w _ setbe, ; :w _ setae, ;
-:w _ setz, ; :w _ setnz, ; 'w _&& 'w _||
-
-: logop, ( opid -- ) >r
- harmonizeops vmop type typeunsigned?
- if _tblunsigned else _tblsigned then r> ( opid ) wexec ;
-
-: vm?:, ( condop -- )
- vmop :>res \ true op in reg
- vmop :push swap vmop :pop vmjnz[, swap vmop :pop \ vmop back to its res
- vmop :compile vmop^ :compile mov, vmop^ :init \ move false op to true reg
- ]vmjmp ;
-
-: vmswitch, ( 'lookup -- )
- vmop^ :noop#
- \ Let's force vmop into AX. After that, none of the other regs are used, so
- \ we're clear to use them in our lookup algo
- vmop :isAX? if vmop :>simple
- else AX regused? not _assert ax vmop :compilesz ?movzx, then
- vmop :init
- di swap ( 'lookup ) m) mov,
- cx di 0 d) mov,
- cx push,
- di CELLSZ i) add,
- repnz, scas,
- cx pop, \ Z preserved
- forward8 jnz,
- \ we have a match
- cx dec, cx 2 i) shl, di cx add, di 0 d) jmp,
- forward! ;
diff --git a/fs/comp/c/vm/vm.fs b/fs/comp/c/vm/vm.fs
@@ -1,6 +0,0 @@
-require sys/scratch.fs
-
-S" /comp/c/vm" curpath :find# ( path )
-$10 syspad :[ ARCH c@+ dup 3 + c, move, ," .fs" syspad :] ( path fname )
-swap Path :child Path :fload
-f<< /comp/c/vm/commonhi.fs
diff --git a/fs/home/codesz.fs b/fs/home/codesz.fs
@@ -19,12 +19,7 @@
." CC\n"
7 stringlist core "asm" "comp" "drv" "fs" "lib" "sys" "xcomp"
core slistlc . nl>
-." C compiler, excluding arch-specific backends\n"
-p" comp/c" dirlc value cclc
-p" comp/c/vm/forth.fs" lc neg to+ cclc
-p" comp/c/vm/i386.fs" lc value i386lc
-i386lc neg to+ cclc
-cclc . nl>
-." i386 assembler and CC backend\n"
-p" asm/i386.fs" lc to+ i386lc
-i386lc . nl>
+." C compiler\n"
+p" comp/c" dirlc . nl>
+." i386 assembler\n"
+p" asm/i386.fs" lc . nl>
