commit 68b95efc36ff812e8de90bd4d7545b1c2f5c2c81
parent e0edbbe1c8735a497322d034e8de1b335d5e0113
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 12 Nov 2022 20:06:58 -0500
cc: move pointer arithmetic logic from ast/ttr to vm
I was hitting a wall with a missing pointer arithmetic logic implementation for
++op, --op, op++ and op--. Implementing those through AST manipulation was more
complicated than it should. Deferring this task to the VM layer ended up being
simpler.
Diffstat:
7 files changed, 40 insertions(+), 36 deletions(-)
diff --git a/fs/cc/ast.fs b/fs/cc/ast.fs
@@ -142,16 +142,6 @@ extends ASTNode struct[ Arrow
]struct
struct+[ ASTNode
- : _ ( opid n self -- ) >r ( opid n )
- Constant :new ( opid cnode )
- swap AST_BINARYOP Op :new dup r@ Node :replace ( cnode bnode )
- r> over Node :add ( cnode bnode ) Node :add ;
-
- \ Multiply the value of "node" by a factor of "n"
- : :*=n ( n self -- ) 2 ( * ) rot> _ ;
- \ Divide the value of "node" by a factor of "n"
- : :/=n ( n self -- ) 3 ( / ) rot> _ ;
-
: :type dup id case ( self )
AST_IDENT of =
Ident :finddecl ?dup _assert CType :type endof
@@ -166,10 +156,6 @@ struct+[ ASTNode
ctype' dup CType :struct? _assert ( name ctype )
CType :find# ( field-ctype ) CType :type endof
drop TYPE_INT endcase ;
-
- \ Return the "pointer arithmetic size" of "node".
- : :*arisz ( self -- n ) :type *ariunitsz ;
- : :ptr? :type type*lvl bool ;
]struct
extends Op struct[ UnaryOp
@@ -186,20 +172,6 @@ extends Op struct[ BinaryOp
: :new ( opid -- node ) AST_BINARYOP Op :new ;
: :new+ 0 ( + opid ) :new ;
: :new= 18 ( = opid ) :new ;
-
- \ 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".
- : :*ari ( self -- )
- dup opid ptrbop? not if drop exit then
- dup firstchild ?dup _assert dup nextsibling ?dup _assert ( self n1 n2 )
- over :ptr? if \ n1 is a pointer
- swap :*arisz over :ptr? if ( self n2 sz ) \ both are pointers
- nip swap :/=n else ( self n2 sz ) \ only n1 is a pointer
- swap :*=n drop then ( )
- else ( self n1 n2 ) \ n1 is not a pointer
- dup :ptr? if ( self n1 n2 ) \ only n2 is a pointer
- :*arisz swap :*=n else 2drop then ( self ) drop then ;
]struct
extends ASTNode struct[ StrLit
diff --git a/fs/cc/ttr.fs b/fs/cc/ttr.fs
@@ -93,7 +93,7 @@ ASTIDCNT wordtbl trtbl ( node -- )
'w drop ( Ident )
:w ( UnaryOp ) dup trchildren UnaryOp :?fold ;
'w trchildren ( PostfixOp )
-:w ( BinaryOp ) dup BinaryOp :*ari dup trchildren BinaryOp :?fold ;
+:w ( BinaryOp ) dup trchildren BinaryOp :?fold ;
'w trchildren ( List )
'w trchildren ( If )
'w drop ( StrLit )
diff --git a/fs/cc/type.fs b/fs/cc/type.fs
@@ -178,6 +178,13 @@ current to _typesize
4 of = TYPE_INT endof
_err endcase ;
+\ TODO: this is a temporary crutch, will reorganize
+: typesize>pow2 ( size -- pow2 ) case
+ 0 of = 0 endof
+ 1 of = 0 endof
+ 2 of = 1 endof
+ 4 of = 2 endof
+ _err endcase ;
\ Returns the "pointer arithmetics unit size" for type, that is, the size of
\ a "single element" in pointer arithmetics. This allows, for example, "ptr + 1"
\ to generate "ptr + 4" in native code if "ptr" is a "int*".
diff --git a/fs/cc/vm/commonhi.fs b/fs/cc/vm/commonhi.fs
@@ -8,16 +8,33 @@
: unopmut doer , does> @ 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 :*arisz typesize>pow2 vmop^ :<<n then
+ vmop^ :typeptr? vmop :typeptr? not and if
+ vmop^ :*arisz typesize>pow2 vmop :<<n then ;
+
: ariop doer , does> @ ariop, ;
-0 ariop vm+, 1 ariop vm-, 2 ariop vm*, 3 ariop vm/,
+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 typesize>pow2 1 ( - ) ariop, ( shr ) vmop :>>n
+ else 1 ( - ) ariop, then ;
+
: assignop doer , does> @ assignop, ;
-0 assignop vm+=, 1 assignop vm-=, 2 assignop vm*=, 3 assignop vm/=,
+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, ;
+
: logop doer , does> @ logop, ;
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/cc/vm/commonlo.fs b/fs/cc/vm/commonlo.fs
@@ -55,7 +55,9 @@ struct[ VMOp
: :init VM_NONE over to loc TYPE_INT swap to type ;
: :loclo loc $f and ;
\ Is loc a pointer?
- : :pointer? loc $10 and bool ;
+ : :locptr? loc $10 and bool ;
+ \ Is type a pointer?
+ : :typeptr? type type*lvl bool ;
: :isconst? loc VM_CONSTANT = ;
: :noop# loc VM_NONE = _assert ;
: :hasop# loc VM_NONE <> _assert ;
@@ -65,7 +67,7 @@ struct[ VMOp
: :push ( self -- 'copy ) dup >r :keep VM_NONE to r> loc ;
: :pop ( 'copy self -- ) dup :noop# 12 move ;
: :swap ( 'copy self -- 'copy ) dup :push rot> :pop ;
- : :&loc dup :pointer? _assert dup :loclo swap to loc ;
+ : :&loc dup :locptr? _assert dup :loclo swap to loc ;
: :&op dup :&loc dup type type*lvl+ swap to type ;
: :*op dup loc case
VM_CONSTANT of = endof
@@ -75,6 +77,7 @@ struct[ VMOp
VM_TOS of = endof
_err endcase
dup loc $10 or over to loc dup type type*lvl- swap to type ;
+ : :*arisz ( self -- n ) type *ariunitsz ;
]struct
create operands VMOp SZ 2 * allot
diff --git a/fs/cc/vm/forth.fs b/fs/cc/vm/forth.fs
@@ -40,16 +40,18 @@ struct+[ VMOp
\ Resolve current operand and compile a push to PS as either VM_TOS or
\ VM_*TOS.
: :compile& >r
- r@ :pointer? if r@ :loclo r@ _ r> :>*TOS else r@ loc r@ _ r> :>TOS then ;
+ r@ :locptr? if r@ :loclo r@ _ r> :>*TOS else r@ loc r@ _ r> :>TOS then ;
: :typesz! type typesize sz! ;
\ Resolve current operand and forces dereferencing. Always yields VM_TOS.
: :compile ( -- ) >r
r@ :compile& r@ loc VM_*TOS = if r@ :typesz! compile @ r@ :>TOS then rdrop ;
: :>reg dup :loclo VM_REGISTER = if drop exit then >r
- r@ :hasop# r@ :pointer? ( f ) r@ :compile& r@ 'arg litn compile ! PS- ( f )
+ r@ :hasop# r@ :locptr? ( f ) r@ :compile& r@ 'arg litn compile ! PS- ( f )
4 lshift VM_REGISTER or to r> loc ;
\ dereference current operand
- : :*op dup :pointer? if dup :compile dup :>reg then VMOp :*op ;
+ : :*op dup :locptr? if dup :compile dup :>reg then VMOp :*op ;
+ : :<<n ( n self -- ) tuck :compile litn compile lshift :>reg ;
+ : :>>n ( n self -- ) tuck :compile litn compile rshift :>reg ;
]struct
\ Verify that we're in "neutral" position with regards to PS
diff --git a/fs/cc/vm/i386.fs b/fs/cc/vm/i386.fs
@@ -106,6 +106,9 @@ struct+[ VMOp
\ Ensure that vmop is a proper "result", that is, a proper destination operand
\ that is not going to mutate its original value.
: :>res dup :>reg :>simple ;
+
+ : :<<n ( n self -- ) dup :>res :compile i) shl, ;
+ : :>>n ( n self -- ) dup :>res :compile i) shr, ;
]struct
\ Verify that we're in "neutral" position with regards to registers
