commit 359a6cfb850204d3cb0f9e8f4555dae05bfa4016
parent 9d269a11bbd53ee10ada1dacb993fed989fa5922
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Thu, 1 Dec 2022 20:28:01 -0500
comp/c: simplify CONSTARRAY handling
Count size in bytes instead of number of elements. It makes it easier to move
around later. In terms of LOC, we don't gain much, but the system is easier to
reason about and it's more flexible. My idea is to make string literals into
CONSTARRAY. That will simplify further.
Diffstat:
5 files changed, 61 insertions(+), 61 deletions(-)
diff --git a/fs/comp/c/pgen.fs b/fs/comp/c/pgen.fs
@@ -363,37 +363,41 @@ alias noop parseStatement ( tok -- ) \ forward declaration
ops$ r> to _laststmtid ;
current to parseStatement
-$100 const MAXCONSTARRAYLEN
-create _constarray MAXCONSTARRAYLEN 1+ CELLSZ * allot
-: parseList ( -- )
- _constarray CELLSZ + begin ( a )
- nextt parseFactor vmop :isconst# vmop arg vmop :init swap !+ ( a )
- ',' readChar? not until ( a tok )
- '}' expectChar ( a )
- _constarray - CELLSZ / 1- ( len ) _constarray !
- _constarray constarray>op ;
+$400 const CONSTARRAYBUFSZ
+create _constarray CONSTARRAYBUFSZ allot
+: _!+ ( sz -- ) case 1 of = c!+ endof 2 of = 16b !+ endof !+ endcase ;
+: parseList ( ctype -- ctype )
+ dup CType type typesize >r \ V1=typesize
+ _constarray CELLSZ + begin ( ctype a )
+ nextt parseFactor vmop :isconst#
+ vmop arg vmop :init swap r@ _!+ ( ctype a )
+ ',' readChar? not until ( ctype a tok )
+ '}' expectChar ( ctype a )
+ _constarray - CELLSZ - ( len ) _constarray !
+ _constarray constarray>op rdrop ;
\ 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
\ result in vmop
-: parseDeclInit ( -- ) '{' readChar? if parseList else parseExpression then ;
+: parseDeclInit ( ctype -- ctype )
+ '{' readChar? if parseList else parseExpression then ;
: parseDeclLine ( type -- )
- parseDeclarator
- _locvars ?dup if CType :append else to _locvars then begin ( )
- '=' readChar? if ( )
+ parseDeclarator ( ctype )
+ dup _locvars ?dup if CType :append else to _locvars then begin ( ctype )
+ '=' readChar? if ( ctype )
_initcode not if
\ when there is init code, it's possible, because we declare new types,
\ that the type arena allocate a new buffer right in the middle of our
\ init code. that's bad. To avoid this, we "reserve" an arena buf now.
cctypearena Arena :reserve
here to _initcode then
- parseDeclInit selop^ _locvars llend ctype>op vm=, ops$ nextt then ( tok )
- dup ';' isChar? not while ( tok )
- ',' expectChar _locvars llend CType type parseDeclarator ( ctype )
- _locvars CType :append repeat ( tok ) drop ;
+ parseDeclInit selop^ dup ctype>op 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 ;
: parseFunction ( ctype -- )
dup addSymbol 0 to _locvars 0 to _initcode to _curfunc ( )
@@ -418,10 +422,7 @@ create _constarray MAXCONSTARRAYLEN 1+ CELLSZ * allot
'=' readChar? if ( ctype )
parseDeclInit vmop loc case ( ctype )
VM_CONSTANT of = vmop arg , endof
- VM_CONSTARRAY of = dup CType type typesize case
- 1 of = vmop arg @+ >r begin @+ c, next drop endof
- 2 of = vmop arg @+ >r begin @+ 16b , next drop endof
- vmop arg @+ CELLSZ * move, endcase endof
+ VM_CONSTARRAY of = vmop arg @+ move, endof
_err endcase ops$
else to nexttputback dup CType :size allot then ( ctype )
',' readChar? if
diff --git a/fs/comp/c/vm/commonlo.fs b/fs/comp/c/vm/commonlo.fs
@@ -36,7 +36,7 @@ $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 an array with the 1st elem being length
+$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
diff --git a/fs/comp/c/vm/forth.fs b/fs/comp/c/vm/forth.fs
@@ -78,6 +78,21 @@ struct+[ VMOp
\ Push active op to PS.
: vmpspush, vmop :compile$ PS- ;
+\ Jumping
+: ]vmjmp ( 'jump_addr -- ) here swap ! ;
+: vmjmp, ( a -- ) [compile] again ;
+: vmjmp[, ( -- a ) compile (br) here 4 allot ;
+\ 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.
+: _ vmop^ :noop# vmop :compile$ PS- 0 to@! psoff ?dup if
+ dup p', compile ! CELLSZ - ?dup if p+, then then ;
+: vmjz, ( a -- ) _ [compile] until ;
+: vmjz[, ( -- a ) _ [compile] if ;
+: vmjnz, ( a -- ) _ compile not [compile] until ;
+: vmjnz[, ( -- a ) _ compile not [compile] if ;
+
UNOPCNT wordtbl unop
'w neg 'w ^ 'w bool 'w not
: unop, ( opid -- ) vmop :compile$ unop swap wexec, vmop :>reg ;
@@ -117,11 +132,11 @@ ARIOPCNT 1+ ( for = ) wordtbl _tbl
\ op2. In other words, perform a AST_ASSIGN with the right part as op2
\ and the left part as op1.
: _movarray, \ special case, we have a {1, 2, 3} assign
- vmop loc VM_STACKFRAME = _assert
- vmop type type*lvl- typesize vmop :compile ( sz ) \ dst on PS
- vmop^ arg @+ ( sz a len ) >r begin ( sz a )
- @+ litn compile swap over sz! compile !+ next compile drop PS- ( sz a )
- 2drop vmop^ :init ;
+ vmop loc VM_STACKFRAME = _assert
+ vmop^ arg vmop^ :init @+ ( a sz )
+ vmjmp[, >r tuck here rot> move, r> ]vmjmp ( sz src )
+ litn vmop :compile litn \ on compiled PS: src dst len
+ compile move PS- ;
\ an assignop, is like a unop in the sense that it operates directly on op1, but
\ with the participation of op2.
@@ -147,25 +162,9 @@ LOGOPCNT wordtbl _tblunsigned
: logop, ( opid -- )
vmop type typeunsigned? if _tblunsigned else _tblsigned then _binop, ;
-\ Jumping
-: ]vmjmp ( 'jump_addr -- ) here swap ! ;
-: vmjmp, ( a -- ) [compile] again ;
-: vmjmp[, ( -- a ) compile (br) here 4 allot ;
-\ 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.
-: _ vmop^ :noop# vmop :compile$ PS- 0 to@! psoff ?dup if
- dup p', compile ! CELLSZ - ?dup if p+, then then ;
-: vmjz, ( a -- ) _ [compile] until ;
-: vmjz[, ( -- a ) _ [compile] if ;
-: vmjnz, ( a -- ) _ compile not [compile] until ;
-: vmjnz[, ( -- a ) _ compile not [compile] if ;
-
: 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 ;
-
diff --git a/fs/comp/c/vm/i386.fs b/fs/comp/c/vm/i386.fs
@@ -123,6 +123,19 @@ struct+[ VMOp
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.
@@ -220,10 +233,10 @@ ASSIGNOPCNT wordtbl _tbl
: _movarray
vmop loc VM_STACKFRAME = _assert
- vmop :*op vmop^ arg @+ ( a len ) >r begin ( a )
- vmop :dest# vmop :compilesz @+ i) mov, ( a+4 )
- vmop type typesize to+ vmop arg next ( a )
- drop vmop^ :init ;
+ vmop :>reg vmop^ arg vmop^ :init @+ ( a sz )
+ vmjmp[, >r tuck here rot> move, r> ]vmjmp ( sz src )
+ si i) mov, cx i) mov, di vmop :compile mov,
+ rep, movsb, ;
: assignop, ( opid -- )
vmop^ loc VM_CONSTARRAY = if \ special case, we have a {1, 2, 3} assign
@@ -281,19 +294,6 @@ LOGOPCNT wordtbl _tblunsigned
: logop, ( opid -- )
vmop type typeunsigned? if _tblunsigned else _tblsigned then swap wexec ;
-\ 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, ;
-
: vm?:, ( condop -- )
vmop :>res \ true op in reg
vmop :push swap vmop :pop vmjnz[, swap vmop :pop \ vmop back to its res
diff --git a/fs/tests/comp/c/type.fs b/fs/tests/comp/c/type.fs
@@ -1,5 +1,5 @@
?f<< /tests/harness.fs
-?f<< /comp/c/type.fs
+?f<< /comp/c/cc.fs
testbegin
\ Tests for CC types
