duskos

dusk os fork
git clone git://git.alexwennerberg.com/duskos
Log | Files | Refs | README | LICENSE

commit e25e72d199a6b7ad1f412af0e222ad044b2d707b
parent aae2ffe77a3cc79a16182f5e89ef572531d3ab23
Author: Virgil Dupras <hsoft@hardcoded.net>
Date:   Mon, 20 Jun 2022 18:20:30 -0400

cc/gen: remove special case for '=' binop

Things are getting delicate with pointer arithmetics, I need all the clarity I
can get.

Diffstat:
Mfs/cc/gen.fs | 96++++++++++++++++++++++++++++++++++++++++++++-----------------------------------
Mfs/cc/vm.fs | 8+++-----
2 files changed, 56 insertions(+), 48 deletions(-)

diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs @@ -5,6 +5,40 @@ : _err ( node -- ) printast abort" unexpected node" ; +alias noop gennode ( node -- ) \ forward declaration + +: genchildren ( node -- ) + firstchild ?dup if begin dup gennode nextsibling ?dup not until then ; + +: spit ( a u -- ) A>r >r >A begin Ac@+ .x1 next r>A ; +: getfuncmap ( node -- funcentry ) AST_FUNCTION parentnodeid data2 ; +: lvvar ( lvnode -- varentry ) + dup data1 swap getfuncmap ( name funcentry ) findvarinmap ; + +\ Multiply the value of "node" by a factor of "n" +\ TODO: support lvalues and expressions +: node*=n ( n node -- ) + dup astid case ( n node ) + AST_CONSTANT of = tuck data1 * swap data1! endof + _err + endcase ; + +\ Return the "pointer arithmetic size" of "node". +: node*arisz ( node -- n ) + dup astid AST_LVALUE = if ( node ) + lvvar vmap.decl data2 ( type ) *ariunitsz ( n ) else + drop 1 then ; + +\ given a BinaryOp node "bnode", verify whether pointer arithmetic adjustments +\ are necessary. If one of the operands is a pointer and the other is not, +\ multiply the "not a pointer" one by the pointer's "arithmetic size". +: bop*ari ( bnode -- ) + firstchild ?dup _assert dup nextsibling ?dup _assert ( n1 n2 ) + 2dup node*arisz swap node*arisz 2dup = if \ same *arisz, nothing to do + 2drop 2drop else \ different *arisz, adjust + ( n1 n2 sz2 sz1 ) < if swap then ( node-to-adjust pointer-node ) + node*arisz swap node*=n then ; + UOPSCNT wordtbl uopgentbl ( -- ) :w ( - ) vmneg, ; :w ( ~ ) vmnot, ; @@ -18,6 +52,21 @@ POPSCNT wordtbl popgentbl ( -- ) :w ( ++ ) vmop++, ; :w ( -- ) vmop--, ; +BOPSCNT wordtbl bopgentblpre ( node -- node ) +:w ( + ) dup bop*ari ; +'w noop ( - ) +'w noop ( * ) +'w noop ( / ) +'w noop ( < ) +'w noop ( > ) +'w noop ( <= ) +'w noop ( >= ) +'w noop ( == ) +'w noop ( != ) +'w noop ( && ) +'w noop ( || ) +'w noop ( = ) + BOPSCNT wordtbl bopgentblmiddle ( node -- node ) 'w noop ( + ) 'w noop ( - ) @@ -46,46 +95,7 @@ BOPSCNT wordtbl bopgentblpost ( -- ) :w ( != ) abort" TODO" ; 'w vmjmp! ( && ) 'w vmjmp! ( || ) -'w noop ( = ) - -alias noop gennode ( node -- ) \ forward declaration - -: genchildren ( node -- ) - firstchild ?dup if begin dup gennode nextsibling ?dup not until then ; - -: spit ( a u -- ) A>r >r >A begin Ac@+ .x1 next r>A ; -: getfuncmap ( node -- funcentry ) AST_FUNCTION parentnodeid data2 ; -: lvvar ( lvnode -- varentry ) - dup data1 swap getfuncmap ( name funcentry ) findvarinmap ; - -\ Multiply the value of "node" by a factor of "n" -\ TODO: support lvalues and expressions -: node*=n ( n node -- ) - dup astid case ( n node ) - AST_CONSTANT of = tuck data1 * swap data1! endof - _err - endcase ; - -\ Return the "pointer arithmetic size" of "node". -: node*arisz ( node -- n ) - dup astid AST_LVALUE = if ( node ) - lvvar vmap.decl data2 ( type ) *ariunitsz ( n ) else - drop 1 then ; - -\ given a BinaryOp node "bnode", verify whether pointer arithmetic adjustments -\ are necessary. If one of the operands is a pointer and the other is not, -\ multiply the "not a pointer" one by the pointer's "arithmetic size". -: bop*ari ( bnode -- ) - firstchild ?dup _assert dup nextsibling ?dup _assert ( n1 n2 ) - 2dup node*arisz swap node*arisz 2dup = if \ same *arisz, nothing to do - 2drop 2drop else \ different *arisz, adjust - ( n1 n2 sz2 sz1 ) < if swap then ( node-to-adjust pointer-node ) - node*arisz swap node*=n then ; - -: _assign ( node -- ) - firstchild ?dup not if _err then ( lvnode ) - dup nextsibling ?dup not if _err then ( lvnode exprnode ) - selop1 gennode selop2 gennode op1<>op2 op2>*op1 ; +:w ( = ) op2>*op1 ; ASTIDCNT wordtbl gentbl ( node -- ) 'w drop ( Declare ) @@ -113,12 +123,12 @@ ASTIDCNT wordtbl gentbl ( node -- ) :w ( PostfixOp ) dup genchildren data1 popgentbl swap wexec ; -:w ( BinaryOp ) dup data1 12 = if _assign exit then +:w ( BinaryOp ) ( node ) >r selop2 noop# selop1 optype if oppush 1 else 0 then ( reg? f ) r@ childcount 2 = not if abort" binop node with more than 2 children!" then - r@ bop*ari - r@ firstchild dup nextsibling swap ( n2 n1 ) + r@ bopgentblpre r@ data1 wexec ( node ) + firstchild dup nextsibling swap ( n2 n1 ) selop1 gennode bopgentblmiddle r@ data1 wexec selop2 gennode bopgentblpost r> data1 wexec ( reg? f ) if op1<>op2 selop1 oppop then ; diff --git a/fs/cc/vm.fs b/fs/cc/vm.fs @@ -95,6 +95,7 @@ operands value 'curop selop2 opdeinit selop1 opdeinit reglvl if abort" unbalanced reg allot/free" then operands 16 0 fill ; +: .ops 4 >r operands begin dup @ .x spc> 4 + next drop nl> ; \ Managing operands @@ -157,12 +158,9 @@ operands value 'curop VM_*REGISTER of = opderef VM_*REGISTER optype! endof _err endcase ; -\ Force the op into a register and then reset the op to VM_NONE -: oppush ( -- regid ) op>reg VM_NONE optype! oparg ; +: oppush ( -- oparg optype ) oparg optype VM_NONE optype! ; -\ Assuming that current op is VM_NONE, set it back to VM_REGISTER, its arg to -\ the current register at reglvl -: oppop ( regid -- ) noop# VM_REGISTER optype! oparg! ; +: oppop ( oparg optype -- ) noop# optype! oparg! ; \ Copy the contents of op2 in the memory address pointed out by op1 and deinit \ op2. In other words, perform a AST_ASSIGN with the right part as op2