commit 7db8046386693e79867acc68b95d5144f313e98e
parent a1f9afe5eaf7a4a31a2f01bf00d0e4b3b580e24f
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Mon, 29 Aug 2022 17:53:56 -0400
Move "to" semantics up a notch in "immediateness"
When compiling a word with "to" semantics, we now compile its "to" word directly
instead of having the "to" mechanism be executed at runtime. The downside of
this approach is increased binary size, but there are two upsides:
1. Less "to" conflicts. Except for interpret time "to" usage, the "toptr" global
variable is only used at compile time. This means that the toptr flips over
much much less often. It also removes the need for "saving" the value of
toptr during "maybeword".
2. It's faster because the "to" decision is only made at compile time.
Diffstat:
7 files changed, 27 insertions(+), 82 deletions(-)
diff --git a/fs/drv/pc/pci.fs b/fs/drv/pc/pci.fs
@@ -71,7 +71,7 @@ create _rdmask 8 allot
current _currentlist ! 4 to+ _currentlist
'"' expectchar current 'emeta lladd drop
META_FIELDDESC , [compile] S" drop does> ( n? 'field )
- c@+ dup >r dup _pcireg@ _buf + swap c@ ( n? a width R:off ) to? if
+ c@+ dup >r dup _pcireg@ _buf + swap c@ ( n? a width R:off ) 0 toptr @! if
_n! r> _pcireg! else rdrop _n@ then ;
: pcifield4 2 swap pcifield ;
diff --git a/fs/fs/fatlo.fs b/fs/fs/fatlo.fs
@@ -178,7 +178,7 @@ extends File struct[ FATFile
sfield entryoff
\ beginning of a buffer with the size :ClusterSize
SZ &+ :buf(
- : :fat compile fat [compile] _FAT ; immediate
+ : :fat [compile] fat [compile] _FAT ; immediate
: _clustersize ( self -- n ) :fat :ClusterSize ;
: :)buf ( self -- a ) dup :buf( swap _clustersize + ;
: :free? ( self -- f ) flags not ;
diff --git a/fs/lib/struct.fs b/fs/lib/struct.fs
@@ -1,38 +0,0 @@
-\ Structures
-
-\ This unit helps the management of structures in memory. A structure is a
-\ address in memory where offsets compared to this address are mapped to names.
-\ Here's an example:
-
-\ struct Pos bfield pos.x bfield pos.y
-
-\ This structure will be 8 bytes in size, x maps to Pos+0, y maps to Pos+4.
-\ But up until now, our Pos exists nowhere. This unit doesn't manage structure
-\ allocation in memory, you have to take care of this yourself. But once you
-\ did, how will pos.x and pos.y know where to go? Pos is a simple value that is
-\ expected to point to its current "base" address:
-
-\ here to Pos 42 , 12 ,
-\ pos.x .x1 --> 2a
-\ pos.y .x1 --> 0c
-
-\ You want to use another Pos structure? Simply write its address to Pos.
-
-\ Struct fields support the "to" semantics:
-\ 54 to pos.x
-
-\ The "b" in "bfield" is for "bound".
-
-
-0 value laststruct
-0 value lastoffset
-
-: struct 0 value current to laststruct 0 to lastoffset ;
-
-: bfield doer laststruct to' execute , lastoffset , 4 to+ lastoffset does>
- dup @ @ swap 4 + @ + to? ?dup if execute else @ then ;
-
-\ A 'bfield returns the address of the field instead of the value. It doesn't
-\ follow "to" semantics and does not increase struct size.
-: 'bfield doer laststruct to' execute , lastoffset , does>
- dup @ @ swap 4 + @ + ;
diff --git a/fs/sys/file.fs b/fs/sys/file.fs
@@ -76,7 +76,7 @@ struct[ Path
\ TODO implement truncating for when dstfile is larger than self.
: _copyfile ( dst src -- ) \ arguments are opened File
>r >r begin \ V1=src V2=dst
- V1 File size V1 File :readbuf ?dup while ( a n ) V2 IO :write repeat
+ V1 File size V1 File :readbuf ?dup while ( a n ) V2 IO :write repeat
r> File :close r> File :close ;
: :copyfile ( dst self -- ) \ arguments are paths
:open >r :open r> _copyfile ;
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -87,17 +87,21 @@ create _ 0 ,
: doer code compile (does) HERE @ _ ! CELLSZ allot ;
: does> r> ( exit current definition ) _ @ ! ;
: does' ( w -- 'data ) CALLSZ + CELLSZ + ;
-: to ['] ! TOPTR ! ;
-: to+ ['] +! TOPTR ! ;
-: to' ['] noop TOPTR ! ;
-: to@ ['] @ TOPTR ! ;
-: to@! ['] @! TOPTR ! ;
-: to? 0 TOPTR @! ;
-: value doer , does> to? ?dup if execute else @ then ;
-: ivalue doer , does> @ to? ?dup if execute else @ then ;
+create toptr 0 ,
+: to ['] ! toptr ! ; immediate
+: to+ ['] +! toptr ! ; immediate
+: to' ['] noop toptr ! ; immediate
+: to@ ['] @ toptr ! ; immediate
+: to@! ['] @! toptr ! ; immediate
+: toexec ( a w -- ) compiling if
+ swap litn 0 toptr @! ?dup if nip then execute, else
+ 0 toptr @! ?dup if nip then execute then ;
+: value doer , immediate does> ['] @ toexec ;
+: ivalue doer , immediate does> @ ['] @ toexec ;
HERE ivalue here
-: alias ' doer , does> to? ?dup if execute else @ execute then ;
-: ialias doer , does> @ to? ?dup if execute else @ execute then ;
+: _ @ execute ;
+: alias ' doer , immediate does> ['] _ toexec ;
+: ialias doer , immediate does> @ ['] _ toexec ;
IN< ialias in<
EMIT ialias emit
ABORT ialias abort
@@ -129,7 +133,7 @@ alias abort key
\ need to use "r@".
: case ( -- then-stopgap ) 0 [compile] >r ; immediate
: of ( -- jump-addr ) [compile] r@ ' execute, [compile] if ; immediate
-alias else endof immediate
+: endof [compile] else ; immediate
: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
?dup if begin [compile] then ?dup not until then [compile] rdrop ; immediate
@@ -188,7 +192,7 @@ alias noop [then]
\ Alias chaining. See doc/usage.
: _ ( 'target 'alias -- )
- here swap to@! execute ( 'tgt 'prevtgt )
+ here swap [compile] to@! execute ( 'tgt 'prevtgt )
litn execute, exit, ;
: chain
' ' ( 'alias 'target ) compiling if
@@ -196,8 +200,9 @@ alias noop [then]
swap _ then ; immediate
\ Local variables
-: _varto ( a -- ) to? ?dup if execute else @ then ;
-: var, ( off -- ) [rcnt] @ neg CELLSZ - -^ r', compile _varto ;
+: var, ( off -- )
+ [rcnt] @ neg CELLSZ - -^ r',
+ 0 toptr @! ?dup if execute, else compile @ then ;
: V1 0 var, ; immediate : V2 4 var, ; immediate
: V3 8 var, ; immediate : V4 12 var, ; immediate
@@ -228,8 +233,9 @@ does> ( 'struct )
\ Rewind the sysdict to our struct
_cur sysdict @! _cur e>w does' ! ;
-: _val' ( 'data 'off -- a ) @ + ;
-: field ( off -- ) doer , does> _val' to? ?dup if execute else @ then ;
+: field ( off -- ) doer , immediate does> @ ( off ) compiling if ( off )
+ litn compile + 0 toptr @! ?dup if execute, else compile @ then else
+ + 0 toptr @! ?dup if execute else @ then then ;
: method ( off -- ) doer , does> @ over + @ execute ;
: sfield _cur e>w structsz field _cur e>w _struct+ ;
: smethod _cur e>w structsz method _cur e>w _struct+ ;
@@ -271,7 +277,7 @@ struct[ Filesystem
smethod :newfile
smethod :newdir
smethod :remove
- : :drv compile drv [compile] Drive ; immediate
+ : :drv [compile] drv [compile] Drive ; immediate
: :writeable? flags 1 and ;
]struct
\ bootfs holds a reference to boot FS. This is used until the full sys/file
diff --git a/fs/xcomp/i386.fs b/fs/xcomp/i386.fs
@@ -24,7 +24,7 @@
\ Constants and labels
0 to realmode
: values ( n -- ) >r begin 0 value next ;
-26 values L1 L2 lblmainalias lbltoptr lblbootptr lblin< lblabort
+25 values L1 L2 lblmainalias lblbootptr lblin< lblabort
lblcurword lblnextmeta lblret lblsysdict lblemit lblparsec lblparseh
lblparseud lblerrmsg lblrtype lblhere lbl[rcnt] lblmovewrite lblwrite
lblcwrite lblfind lblcompiling lblareg lblidt
@@ -49,11 +49,6 @@ forward16 jmp, to L1
xcode noop pc to lblret ret,
-align4 pc to lbltoptr 0 ,
-xcode TOPTR
- lbltoptr pspushN,
- ret,
-
xcode (cell)
ax pop,
AX pspush,
@@ -125,7 +120,6 @@ xcode compiling
xcode quit
cld,
- lbltoptr m) 0 i) mov,
sp RSTOP i) mov,
lblmainalias m) jmp,
@@ -550,18 +544,11 @@ xcode curword
ret,
pc to L1 ( word_eof )
- ax pop,
- lbltoptr m) ax mov,
ax ax xor,
AX pspush,
ret,
xcode maybeword ( -- str-or-0 )
- \ save lbltoptr so that it doesn't mess in<, which could be calling a word
- \ with "to" semantics.
- ax lbltoptr m) mov,
- ax push,
- lbltoptr m) 0 i) mov,
pc ( loop1 )
lblin< m) call,
AX pspop,
@@ -582,8 +569,6 @@ pc ( loop2 )
ax SPC 1+ i) cmp, \ is ws?
( loop2 ) abs>rel jnc,
L1 forward! ( stoploop )
- ax pop,
- lbltoptr m) ax mov,
bx lblcurword 1+ i) sub,
lblcurword m) bl mov,
lblcurword pspushN,
diff --git a/posix/vm.c b/posix/vm.c
@@ -160,7 +160,6 @@ static void BYEFAIL() { // op: 05
}
static void QUIT() { // op: 06
- sd(TOPTR, 0);
vm.RSP = RSTOP;
vm.PC = gd(MAINLOOP);
}
@@ -523,15 +522,10 @@ static void STACKCHK() { // op: 50
static void MAYBEWORD() { // op: 51
dword c, a;
- // save toptr so that it doesn't mess in<, which could be calling a word
- // with to semantics
- dword toptr = gd(TOPTR);
- sd(TOPTR, 0);
do {
callword(gd(INRD));
c = ppop();
if (c >> 31) { // EOF
- sd(TOPTR, toptr);
ppush(0);
return;
}
@@ -542,7 +536,6 @@ static void MAYBEWORD() { // op: 51
callword(gd(INRD));
c = ppop();
} while (!(c >> 31) && (c > ' '));
- sd(TOPTR, toptr);
sb(CURWORD, a-CURWORD-1); // len
ppush(CURWORD);
}
@@ -974,7 +967,6 @@ static void buildsysdict() {
sysconst("ABORT", ABORT);
sysconst("MAIN", MAINLOOP);
sysconst("HERE", HERE);
- sysconst("TOPTR", TOPTR);
sysconst("heremax", HEREMAX);
sysconst("curword", CURWORD);
sysconst("sysdict", SYSDICT);
