commit b680be0787e73207b0b38ebe53ab07a5e7972747
parent b77150410193afd8360f65314c95d26c5e07c0cc
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 25 Feb 2023 08:17:12 -0500
Add the concept of A register
Another of my grand ideas! This is *not* the same thing as the A register in
Collapse OS. See doc/stc for details.
For now, the main gain is speed, but that's not the ultimate goal. I have an
even granderer idea for an important simplification in DuskCC that would
require expanded meta-compilation capabilities such as this in the kernel.
I'm still working out the details...
Diffstat:
11 files changed, 558 insertions(+), 406 deletions(-)
diff --git a/fs/comp/c/vm/forth.fs b/fs/comp/c/vm/forth.fs
@@ -17,9 +17,9 @@ struct+[ VMOp
: _compile ( arg loc -- ) \ compile "straight" operands, errors on * ops.
case ( arg )
VM_CONSTANT of = litn PS+ endof
- VM_STACKFRAME of = r', PS+ endof
- VM_ARGSFRAME of = psoff + p', PS+ endof
- VM_REGISTER of = psoff + p', compile @ PS+ endof
+ VM_STACKFRAME of = RSP>A, A+, A>, PS+ endof
+ VM_ARGSFRAME of = PSP>A, psoff + A+, A>, PS+ endof
+ VM_REGISTER of = PSP>A, psoff + A+, A@, PS+ endof
_err endcase ;
: :compile& dup :locptr? _assert bi arg | :loclo _compile ;
: :typesz! type typesize sz! ;
@@ -61,7 +61,7 @@ struct+[ VMOp
vmop^ :noop# \ returning with a second operand? something's wrong
vmop loc if
vmop :compile$ PS- psoff argsz + ?dup if
- p', compile ! -4 to+ V1 then then
+ PSP>A, A+, A!, -4 to+ V1 then then
r> ( argsz ) 0 to@! psoff + ?dup if p+, then
locsz ?dup if r+, then
exit, ;
@@ -91,7 +91,7 @@ struct+[ VMOp
\ The same logic applies to vmswitch,.
: _compileFinal
vmop^ :noop# vmop :compile$ PS- 0 to@! psoff ?dup if
- dup p', compile ! CELLSZ - ?dup if p+, then then ;
+ dup PSP>A, A+, A!, CELLSZ - ?dup if p+, then then ;
: vmjz, ( a -- ) _compileFinal [compile] until ;
: vmjz[, ( -- a ) _compileFinal [compile] if ;
: vmjnz, ( a -- ) _compileFinal compile not [compile] until ;
diff --git a/fs/doc/arch.txt b/fs/doc/arch.txt
@@ -7,12 +7,6 @@ complete picture, you'll also want to read the hardware-dependent part:
* i386: hw/i386/arch
-## Subroutine Threaded Code
-
-This Forth is a Subroutine Thread Code (STC) Forth, that is, each reference to
-words is a native call instead of being a reference. This means that we don't
-have a "next" interpret loop. It's calls all the way down.
-
## Linked lists
The linked list is a data structure that is heavily used in Dusk: dictionaries
@@ -220,13 +214,6 @@ are documented here:
(cell): Compiled by "create", a call to this word pushes the current PC to PS
and then returns.
-(val): Compiled by "value", it works like a (cell), but instead of pushing the
-address to PS, it reads the 4b value there and pushes that instead. It also
-obeys "to" semantics.
-
-(alias): Compiled by "alias", it works like a (val), but it jumps to the address
-read. Also obeys "to" semantics.
-
(does): Compiled by "doer", it's a hybrid between (alias) and (cell). It pushes
PC+4 to PS, but also reads the 4b int at PC+0 and jumps to its address.
Does *not* obey "to" semantics.
@@ -241,6 +228,3 @@ like (alias), but ignores "to" semantics.
(?br): Compiled by "if" and "until", a conditional branch. It pops from PS and
if the popped value is zero, branches exactly like (br). Otherwise, it continues
to PC+4.
-
-(next): Compiled by "next". Decreases RS TOS by one. If zero is reached, pop it
-from RS and continue to PC+4. If not, branch like (br).
diff --git a/fs/doc/dict.txt b/fs/doc/dict.txt
@@ -41,6 +41,7 @@ indicating a special attribute:
*C* indicates that the word can be compiled. Its description is its behavior in
interpret mode, but when in compile mode, it will "do the right thing" to
compile the same behvior.
+*A* Preserves the A register.
## Symbols
@@ -120,10 +121,7 @@ r> -- *I* Equivalent to r@ rdrop
of PS into that new RS space.
r+, n -- Compile a RS grow (n is negative) or shrink (n is
positive) operation by n bytes.
-r', off -- Compile the yield of RSP with "off" offset applied to
- it. At runtime, this number will be pushed to PS.
p+, n -- Same as r+, but for PS.
-p', off -- Same as r', but for PS.
scnt -- n Number of elements in PS, excluding "n".
rcnt -- n Number of elementS in RS, excluding this call.
stack? -- Error out if scnt < 0.
@@ -371,6 +369,25 @@ to@! --> @!
to@+ --> @@+
to!+ --> @!+
+## A register
+
+All "A register" words are compiler words. Calling them doesn't execute their
+description, it compiles native code that performs the description.
+
+RSP>A, -- Copies RS pointer to A.
+PSP>A, -- Copies PS pointer to A.
+LIT>A, n -- Copies "n" to A.
+>A, -- Pops PS into A.
+A>, -- *A* Pushes A to PS.
+A+, n -- Adds "n" to A.
+[A]+, n -- Adds "n" to 4b location A points to.
+A@, -- *AB* Equivalent to "A>, @"
+A!, -- *AB* Equivalent to "A> !"
+A+!, -- *AB* Equivalent to "A> +!"
+A@!, -- *AB* Equivalent to "A> @!"
+[A]@, -- *AB* Equivalent to "A> @ @"
+[A]!, -- *AB* Equivalent to "A> @ !"
+
## Templates
bi X | Y --> dup X swap Y a -- x y
diff --git a/fs/doc/hw/i386/arch.txt b/fs/doc/hw/i386/arch.txt
@@ -6,6 +6,7 @@ The i386 kernel source code is xcomp/i386/kernel.fs. Register roles:
PSP: EBP
RSP: ESP
+A register: EDI
All other registers are free.
diff --git a/fs/doc/stc.txt b/fs/doc/stc.txt
@@ -0,0 +1,73 @@
+# Dusk OS is a STC
+
+This Forth is a Subroutine Thread Code (STC) Forth, that is, each reference to
+words is a native call instead of being a reference. The drawback to this
+structure, compared to DTC or ITC forths (the ones with a "next" (not the "next"
+from iterators, the "core next of forth")), is significantly bigger binary size.
+It's also more complex to "disassemble" a compiled word. The upsides, however,
+are real juicy.
+
+First, there's speed. Calling words natively is faster than going through a
+"next" loop.
+
+Second, and most importantly, there's the ability for forth code to freely mix
+up with native code. That's huge and we use this extensively in Dusk through
+its "meta compilation" capabilities.
+
+## Meta compilation
+
+The vast majority of forths have the "compile" class of words. That's your
+grampa's compilation and it simply writes down a call to the specified word.
+Dusk kernels go further than that and allow the compilation of further native
+constructs.
+
+### Direct PS/RS control
+
+One of those constructs is direct control over the Parameter and Return Stacks.
+The "p+," compiles native code that grows or shrink PS by the specified number
+of bytes. "r+," does the same thing for RS.
+
+For example, here's the implementation of "drop" (from xcomp/bootlo.fs)
+
+code drop 4 p+, exit,
+
+Under a i386 kernel, this is the exact equivalent of writing "bp 4 i) add, ret,"
+to "here".
+
+In other words, meta compilation words in Dusk are a kind of limited portable
+assembler allowing you to sprinkle native code around.
+
+### The A register
+
+The "A" register is a (ideally) hardware register that helps making some memory-
+related operations less "PS-heavy". "A" is for "Address" and it will generally
+contain a memory address upon which it will work.
+
+Other forths have "A" registers, such as Collapse OS, and this register is
+generally directly used by the operator. Not here. The A register is extremely
+short-lived and will be written over all the time. Few words are guaranteed to
+preserve A, so you'll typically only use it in local, specific places. For
+example, ">r" uses the A register:
+
+: >r -4 r+, RSP>A, A!, ; immediate
+
+RSP>A, compiles native code that copies the RS pointer to the A register and A!,
+compiles native code that pops PS into the address contained in the A register.
+By the way, "A" words are "binary modulated", so "8b A!," will compile a native
+8b write.
+
+The A register generally saves us a roundtrip of the address to PS, resulting
+in considerable speedups. Let's use another example that illustrates it better:
+
+: value doer , immediate does> compiling if LIT>A, then toptr@ execute ;
+
+When we refer to a value in compile mode, we need to compile its address and
+then apply the appropriate "to" word (if any) to it. In "regular" forth, this
+would be implemented with "litn" followed by, for example, "!". This means that
+the address has to be pushed to PS and then popped again during !. With the A
+register, we save ourselves this roundtrip.
+
+This is a small gain, but it's a gain that we get in values, local variables and
+struct field access, so it adds up to nice sums.
+
+See "A register" section in doc/dict for a list of words.
diff --git a/fs/doc/usage.txt b/fs/doc/usage.txt
@@ -1,11 +1,12 @@
# Dusk OS usage
-Warning: this OS is not usable yet. It lacks many convenience words would make
-it usable. But still, it can do many nice tricks...
+Warning: this OS is not usable by mere mortals yet. It lacks many convenience
+words would make it usable. But still, it can do many nice tricks...
Dusk OS is a Forth that generally follows conventions described in "Starting
Forth" by Leo Brodie, except that words are in lowercase. If you don't know
-Forth, it's recommended that you start there.
+Forth, it's recommended that you start there. This documentation assumes this
+knowledge.
Then, you can look at doc/dict to get an broad idea of the vocabulary that is
available to you. You will recognize many words in there from Starting Forth and
@@ -13,6 +14,14 @@ should be able to get started after that.
That being said, Dusk OS has some additional features that need explaining:
+## Subroutine Threaded Code
+
+This Forth is a Subroutine Thread Code (STC) Forth, that is, each reference to
+words is a native call instead of being a reference. This means that we don't
+have a "next" interpret loop. It's calls all the way down.
+
+See doc/stc for detailed information on what it implies.
+
## Number literals
Dusk has no DEC/HEX mode. Number literals are parsed using a prefix system.
@@ -414,6 +423,26 @@ such as :fload, f<< and ?f<<. Refer to doc/sys/file.
If you want to compile C source files, you'll want to look at doc/cc.
+## Where is this word defined?
+
+So, you're reading some code and you're wondering where a particular word is
+defined. As a general rule, you should be aware of your "import context", that
+is, the units that the unit you're reading import (with "?f<<") at the top of
+the file. Most of the time, we try to avoid implicit imports for words we use
+directly in a unit (for example, if unit A imports B which imports C, if A
+directly uses a word from C, it will "document" that usage by explicitly
+importing C even if it's not needed because we import B), so those imports can
+be relied upon.
+
+Therefore, your first step would be to review the documentation of those units
+and see your word is defined there.
+
+All units have implicit import of sys/file and sys/io, so that should also be
+considered in your search.
+
+Then, look in doc/dict. If it's in there, then it's either defined in the native
+kernel code or in xcomp/bootlo.fs.
+
## What now?
This document covers Dusk's basic functionalities. You can try a few things in
diff --git a/fs/tests/kernel.fs b/fs/tests/kernel.fs
@@ -45,6 +45,10 @@ foo 43 #eq
5 to+ foo
foo 48 #eq
to' foo @ 48 #eq
+$12345678 to@! foo 48 #eq
+$6789 16b to@! foo $5678 #eq
+$9a 8b to@! foo $89 #eq
+foo $1234679a #eq
\ [if]..then
1 [if] 42 42 #eq [then]
diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs
@@ -37,9 +37,9 @@ code drop 4 p+, exit,
\ Stack
: rdrop 4 r+, ; immediate
: 2rdrop 8 r+, ; immediate
-: r@ 0 r', compile @ ; immediate
+: r@ RSP>A, A@, ; immediate
: r> [compile] r@ [compile] rdrop ; immediate
-: >r -4 r+, 0 r', compile ! ; immediate
+: >r -4 r+, RSP>A, A!, ; immediate
code 2drop 8 p+, exit,
: 2dup over over ;
@@ -65,27 +65,33 @@ code 2drop 8 p+, exit,
: or? or bool ;
: upcase ( c -- c ) dup 'a' - 26 < if $df and then ;
+: while [compile] if swap ; immediate
+: repeat [compile] again [compile] then ; immediate
+
+: case ( -- then-stopgap ) 0 [compile] >r ; immediate
+: of ( -- jump-addr ) [compile] r@ word compword [compile] if ; immediate
+: endof [compile] else ; immediate
+: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
+ ?dup if begin [compile] then ?dup not until then [compile] rdrop ; immediate
+
\ Local variables + beginning of compiling words
: create code compile (cell) ;
: const code litn exit, ;
4 const CELLSZ
-create toptr 0 ,
-: _toptr@ ( -- w ) 0 toptr @! ?dup not if ['] @ then findmod ;
-: var, ( off -- ) [rcnt] @ neg CELLSZ - -^ r', _toptr@ execute, ;
+
+create toptr 0 , \ pointer to 8b struct [execword, compileword]
+create toptrdef ' @ , ' A@, ,
+: toptr@ ( -- w )
+ toptr @ 0 toptr ! ?dup not if toptrdef then
+ compiling if CELLSZ + then @ findmod ;
+: var, ( off -- ) RSP>A, [rcnt] @ neg CELLSZ - -^ A+, toptr@ execute ;
: V1 0 var, ; immediate : V2 4 var, ; immediate
: V3 8 var, ; immediate : V4 12 var, ; immediate
-
$10 const EMETA_8B
$11 const EMETA_16B
: 8b EMETA_8B MOD ! ; immediate
: 16b EMETA_16B MOD ! ; immediate
-\ Memory
-: w@ 16b @ ;
-: w! 16b ! ;
-: c@+ 8b @+ ;
-: c!+ 8b !+ ;
-
\ Compiling words
\ TODO: 5 is hardcoded, might not work on all arches
5 const CALLSZ
@@ -93,25 +99,63 @@ create _ 0 ,
: doer code compile (does) HERE @ _ ! CELLSZ allot ;
: does> r> ( exit current definition ) _ @ ! ;
: does' ( w -- 'data ) CALLSZ + CELLSZ + ;
-: _to doer ' , immediate does> @ toptr ! ;
-_to to ! _to to+ +! _to to' noop _to to@! @!
-_to to@+ @@+ _to to!+ @!+
-: _toexec ( a -- )
- compiling if litn _toptr@ execute, else _toptr@ execute then ;
+: _to doer ' , ' , immediate does> toptr ! ;
+_to to ! A!, _to to+ +! A+!, _to to' noop A>,
+: _toexec ( a -- ) compiling if LIT>A, then toptr@ execute ;
: value doer , immediate does> _toexec ;
: here HERE _toexec ; immediate
: alias ' code alias, ;
-: realias ( 'new 'tgt -- ) to@! here swap alias, to here ;
-: _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
-: chain ( w1 w2 -- w )
- _ swap _ tuck over and? if here rot execute, swap alias, else ?swap nip then ;
-alias noop idle
+alias @ llnext
+: llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
+: llappend ( elem ll -- ) llend ! ;
+: lladd ( ll -- newll ) here swap llappend here 0 , ;
+
+\ Entry metadata
: &+ ( n -- ) doer , does> @ + ;
: &+@ ( n -- ) doer , does> @ + @ ;
+-4 &+@ emeta
+-4 &+ 'emeta
+: metaadd ( id entry -- ) 'emeta lladd drop , ;
+: code8b EMETA_8B sysdict @ metaadd ;
+: :8b code8b ] ;
+: code16b EMETA_16B sysdict @ metaadd ;
+: :16b code16b ] ;
+
+code @! >A, A@!, exit,
+code16b >A, 16b A@!, exit,
+code8b >A, 8b A@!, exit,
+_to to@! @! A@!,
+code @+ >A, A@, 4 A+, A>, ] swap ;
+code16b >A, 16b A@, 2 A+, A>, ] swap ;
+code8b >A, 8b A@, 1 A+, A>, ] swap ;
+code !+ >A, A!, 4 A+, A>, exit,
+code16b >A, 16b A!, 2 A+, A>, exit,
+code8b >A, 8b A!, 1 A+, A>, exit,
+: _ [A]@, 4 [A]+, ; :16b 16b [A]@, 2 [A]+, ; :8b 8b [A]@, 1 [A]+, ;
+code @@+ >A, _ exit,
+code16b >A, 16b _ exit,
+code8b >A, 8b _ exit,
+_to to@+ @@+ _
+: _ [A]!, 4 [A]+, ; :16b 16b [A]!, 2 [A]+, ; :8b 8b [A]!, 1 [A]+, ;
+code @!+ >A, _ exit,
+code16b >A, 16b _ exit,
+code8b >A, 8b _ exit,
+_to to!+ @!+ _
+
+: w@ 16b @ ;
+: w! 16b ! ;
+: c@+ 8b @+ ;
+: c!+ 8b !+ ;
: &+w@ ( n -- ) doer , does> @ + w@ ;
: &+c@ ( n -- ) doer , does> @ + c@ ;
+: realias ( 'new 'tgt -- ) to@! here swap alias, to here ;
+: _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ;
+: chain ( w1 w2 -- w )
+ _ swap _ tuck over and? if here rot execute, swap alias, else ?swap nip then ;
+alias noop idle
+
alias execute | immediate
: _ compile swap ;
: bi compile dup ['] _ ; immediate
@@ -124,7 +168,7 @@ alias execute | immediate
\ Iteration
: xtcomp [compile] ] begin word runword compiling not until ;
-: ivar, ( off -- ) r', _toptr@ execute, ;
+: ivar, ( off -- ) RSP>A, A+, toptr@ execute ;
: i 4 ivar, ; immediate : j 8 ivar, ; immediate : k 12 ivar, ; immediate
: :iterator doer immediate xtcomp does>
-12 r+, execute, -4 [rcnt] +!
@@ -136,7 +180,7 @@ alias execute | immediate
[compile] yield [compile] again [compile] then
12 r+, 4 [rcnt] +! 0 to@! _breaklbl ?dup drop ; immediate
CALLSZ CELLSZ + const BRSZ
-: unyield compile BRSZ 0 r', compile +! ; immediate
+: unyield RSP>A, BRSZ [A]+, ; immediate
: break 16 r+, [compile] ahead to _breaklbl ; immediate
:iterator for ( n -- )
@@ -155,15 +199,6 @@ CALLSZ CELLSZ + const BRSZ
dup 8b to@+ V2 = if j to@! i to V1 then next ( c )
drop rdrop r> ( i ) ;
-: while [compile] if swap ; immediate
-: repeat [compile] again [compile] then ; immediate
-
-: case ( -- then-stopgap ) 0 [compile] >r ; immediate
-: of ( -- jump-addr ) [compile] r@ word compword [compile] if ; immediate
-: endof [compile] else ; immediate
-: endcase ( then-stopgap jump1? jump2? ... jumpn? -- )
- ?dup if begin [compile] then ?dup not until then [compile] rdrop ; immediate
-
\ Emitting
$20 const SPC $0d const CR $0a const LF $08 const BS $1b const ESC
alias drop emit
@@ -184,20 +219,6 @@ current ' rtype realias
: [if] not if S" [then]" begin word over s= until drop then ;
alias noop [then]
-alias @ llnext
-: llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ;
-: llappend ( elem ll -- ) llend ! ;
-: lladd ( ll -- newll ) here swap llappend here 0 , ;
-
-\ Entry metadata
--4 &+@ emeta
--4 &+ 'emeta
-: metaadd ( id entry -- ) 'emeta lladd drop , ;
-: code8b EMETA_8B sysdict @ metaadd ;
-: :8b code8b ] ;
-: code16b EMETA_16B sysdict @ metaadd ;
-: :16b code16b ] ;
-
$01 const EMETA_DOCLINE \ a doc strings that ends with LF
\ a \\ comment goes before the creation of the word it comments
: \\ nextmeta lladd drop EMETA_DOCLINE , begin in< dup c, LF = until ;
@@ -257,9 +278,9 @@ create _ 0 , EMETA_8B , EMETA_16B ,
current _cur e>w structlastfield' @! ( next ) ,
_cur e>w structsz , ( sz type ) over , , ( sz ) sallot ;
: _svalue ( sz -- ) doer immediate STRUCTFIELD_REGULAR _sfield
- does> CELLSZ + @+ swap @ swap ( a? sz off )
- compiling if ( sz off ) litn compile + _szmeta MOD ! _toptr@ execute,
- else ( a sz off ) rot + ( sz a ) swap _szmeta MOD ! _toptr@ execute then ;
+ does> CELLSZ + @+ dip @ | ( a? sz off )
+ compiling if ( sz off ) >A, A+, else ( a sz off ) rot + swap then ( a? sz )
+ _szmeta MOD ! toptr@ execute ;
: sfield CELLSZ _svalue ;
: sfieldw 2 _svalue ;
: sfieldb 1 _svalue ;
diff --git a/fs/xcomp/i386/kernel.fs b/fs/xcomp/i386/kernel.fs
@@ -1,12 +1,14 @@
\ This is the i386 Dusk kernel. It is called when the bootloader has finished
\ loading this binary as well as the Forth boot code following it in memory.
\ We're in protected mode and all segments have been initialized. ESP and EBP
-\ are uninitialized.
+\ are uninitialized. DI is the A register.
?f<< /asm/i386.fs
?f<< /xcomp/tools.fs
\ Macros
-: wcall, xwordlbl abs>rel call, ;
+: absjmp, abs>rel jmp, ;
+: abscall, abs>rel call, ;
+: wcall, xwordlbl abscall, ;
0 value lblintnoop
: idtgen ( entrycount -- ) for
lblintnoop $ffff and w, $08 w, 0 c, $8e c, lblintnoop 16 rshift w, next ;
@@ -14,9 +16,10 @@
\ Constants and labels
0 to realmode
: values ( n -- ) for 0 value next ;
-20 values lblmainalias lblbootptr lblnextword lblcurword lblnextmeta lblret
+22 values lblmainalias lblbootptr lblnextword lblcurword lblnextmeta lblret
lblsysdict lblparsec lblparseh lblparseud lblerrmsg lblhere lbl[rcnt]
lblmovewrite lblwrite lblcwrite lblfind lblcompiling lblidt lblmod
+ lblrelwr lblcallwr
$8000 const HERESTART
$500 to binstart
$2000 const STACKSZ
@@ -24,6 +27,8 @@ $7c00 const RSTOP
$80000 const PSTOP
PSTOP STACKSZ - const HEREMAX
+: movewrite, ( a u ) cx i) mov, si i) mov, lblmovewrite abscall, ;
+
\ Let's go!
0 align4 here to org
forward16 jmp, to L1
@@ -109,7 +114,7 @@ xcode quit
xcode (abort)
L1 forward!
bp PSTOP i) mov,
- xwordlbl quit abs>rel jmp,
+ xwordlbl quit absjmp,
xcode exit
ax pop,
@@ -286,7 +291,7 @@ xcode c@
ret,
pc 0 , EMETA_8B ,
- xwordlbl c@ abs>rel jmp,
+ xwordlbl c@ absjmp,
pc nextmeta ! ( pc ) , EMETA_16B ,
ax [ebp] mov, \ ax=a
16b! bx ax 0 d) movclr,
@@ -304,7 +309,7 @@ xcode c!
ret,
pc 0 , EMETA_8B ,
- xwordlbl c! abs>rel jmp,
+ xwordlbl c! absjmp,
pc nextmeta ! ( pc ) , EMETA_16B ,
AX BX pspop2, \ ax=a bx=n
16b! ax 0 d) bx mov,
@@ -327,120 +332,16 @@ xcode +! ( n a -- )
ax 0 d) bx add,
ret,
-pc 0 , EMETA_8B ,
- AX pspop, \ ax=a
- bx [ebp] mov, \ bx=n
- cl ax 0 d) movclr,
- ax 0 d) bl mov,
- [ebp] cx mov,
- ret,
-pc nextmeta ! ( pc ) , EMETA_16B ,
- AX pspop, \ ax=a
- bx [ebp] mov, \ bx=n
- 16b! cx ax 0 d) movclr,
- 16b! ax 0 d) bx mov,
- [ebp] cx mov,
- ret,
-xcode @! ( n a -- n )
- AX pspop, \ ax=a
- bx [ebp] mov, \ bx=n
- cx ax 0 d) mov,
- ax 0 d) bx mov,
- [ebp] cx mov,
- ret,
-
-pc 0 , EMETA_8B ,
- ax [ebp] mov, \ ax=a
- bl ax 0 d) movclr,
- [ebp] inc,
- BX pspush,
- ret,
-pc nextmeta ! ( pc ) , EMETA_16B ,
- ax [ebp] mov, \ ax=a
- 16b! bx ax 0 d) movclr,
- [ebp] 2 i) add,
- BX pspush,
- ret,
-xcode @+ ( a -- a+ n )
- ax [ebp] mov, \ ax=a
- bx ax 0 d) mov,
- [ebp] 4 i) add,
- BX pspush,
- ret,
-
-pc 0 , EMETA_8B ,
- ax [ebp] mov, \ ax='a
- bx ax 0 d) mov, \ bx=a
- cl bx 0 d) movclr,
- ax 0 d) inc,
- [ebp] cx mov,
- ret,
-pc nextmeta ! ( pc ) , EMETA_16B ,
- ax [ebp] mov, \ ax='a
- bx ax 0 d) mov, \ bx=a
- 16b! cx bx 0 d) movclr,
- ax 0 d) 2 i) add,
- [ebp] cx mov,
- ret,
-xcode @@+ ( 'a -- n )
- ax [ebp] mov, \ ax='a
- bx ax 0 d) mov, \ bx=a
- cx bx 0 d) mov,
- ax 0 d) 4 i) add,
- [ebp] cx mov,
- ret,
-
-pc 0 , EMETA_8B ,
- AX pspop,
- bx [ebp] mov,
- ax 0 d) bl mov,
- ax inc,
- [ebp] ax mov,
- ret,
-pc nextmeta ! ( pc ) , EMETA_16B ,
- AX pspop,
- bx [ebp] mov,
- 16b! ax 0 d) bx mov,
- ax 2 i) add,
- [ebp] ax mov,
- ret,
-xcode !+ ( n a -- )
- AX pspop,
- bx [ebp] mov,
- ax 0 d) bx mov,
- ax 4 i) add,
- [ebp] ax mov,
- ret,
-
-pc 0 , EMETA_8B ,
- AX CX pspop2, \ ax='a cx=n
- bx ax 0 d) mov, \ bx=a
- bx 0 d) cl mov,
- ax 0 d) inc,
- ret,
-pc nextmeta ! ( pc ) , EMETA_16B ,
- AX CX pspop2, \ ax='a cx=n
- bx ax 0 d) mov, \ bx=a
- 16b! bx 0 d) cx mov,
- ax 0 d) 2 i) add,
- ret,
-xcode @!+ ( n 'a -- )
- AX CX pspop2, \ ax='a cx=n
- bx ax 0 d) mov, \ bx=a
- bx 0 d) cx mov,
- ax 0 d) 4 i) add,
- ret,
-
xcode c,
AX pspop, \ ax=n
-pc to lblcwrite \ al=c
+pc to lblcwrite \ al=c preserves bx
si lblhere m) mov,
[esi] al mov,
lblhere m) inc,
ret,
pc 0 , EMETA_8B ,
- xwordlbl c, abs>rel jmp,
+ xwordlbl c, absjmp,
pc nextmeta ! ( pc ) , EMETA_16B ,
AX pspop, \ ax=n
si lblhere m) mov,
@@ -532,58 +433,24 @@ xcode [rcnt]
lbl[rcnt] pspushN,
ret,
-\ 83 c4 XX --> add esp, XX
-pc 2 nc, $83 $c4
+pc 2 nc, $83 $c4 ( XX ) \ sp XX i) add,
xcode r+, ( n -- )
- si ( pc ) i) mov,
- cx 2 i) mov,
- lblmovewrite abs>rel call,
+ ( pc ) 2 movewrite,
AX pspop,
lbl[rcnt] m) ax add,
- lblcwrite abs>rel jmp,
+ lblcwrite absjmp,
-\ 83 c5 XX --> add ebp, XX
-pc 2 nc, $83 $c5
+pc 2 nc, $83 $c5 ( XX ) \ bp XX i) add,
xcode p+, ( n -- )
- si ( pc ) i) mov,
- cx 2 i) mov,
- lblmovewrite abs>rel call,
- AX pspop,
- lblcwrite abs>rel jmp,
-
-\ 83 ed 04 --> sub ebp, 4
-\ 89 45 00 --> mov [ebp], esp
-pc to L1 6 nc, $83 $ed $04 $89 $45 $00
-
-pc to L2 \ common code between r', and p',
- cx 3 i) mov,
- lblmovewrite abs>rel call,
+ ( pc ) 2 movewrite,
AX pspop,
- lblcwrite abs>rel call,
- si L1 i) mov,
- cx 6 i) mov,
- lblmovewrite abs>rel jmp,
-
-\ 8d 44 24 XX --> lea eax, [esp+XX]
-pc 3 nc, $8d $44 $24
-xcode r', ( n -- )
- si ( pc ) i) mov,
- L2 abs>rel jmp,
-
-\ 8d 45 24 XX --> lea eax, [ebp+XX]
-pc 3 nc, $8d $45 $24
-xcode p', ( n -- )
- si ( pc ) i) mov,
- L2 abs>rel jmp,
+ lblcwrite absjmp,
-\ 58 ff d0 --> ax pop, ax call,
-pc 3 nc, $58 $ff $d0
+pc 3 nc, $58 $ff $d0 \ ax pop, ax call,
xcode yield ximm
- si ( pc ) i) mov,
- cx 3 i) mov,
- lblmovewrite abs>rel jmp,
+ ( pc ) 3 movewrite, ret,
-xcode rtype xwordlbl (abort) abs>rel jmp,
+xcode rtype xwordlbl (abort) absjmp,
\ During early boot, it's better to halt the machine than to go back to the
\ mainloop because the mainloop likely sends us to an infinite error loop
@@ -604,7 +471,7 @@ xcode boot<
ret,
\ where "word" feeds itself
-xcode in< xwordlbl boot< abs>rel jmp,
+xcode in< xwordlbl boot< absjmp,
3 allot \ that last jump is a rel8, we need more space.
pc to lblnextword 0 ,
@@ -672,7 +539,7 @@ pc to lblerrmsg \ exc=sl esi=sa
SI pspush,
CX pspush,
wcall, rtype
- xwordlbl abort abs>rel jmp,
+ xwordlbl abort absjmp,
xcode findmeta ( id ll -- ll-or-0 )
AX pspop,
@@ -683,7 +550,7 @@ pc to L1
bx ax 4 d) cmp,
forward8 jz,
ax ax 0 d) mov,
- L1 abs>rel jmp,
+ L1 absjmp,
forward! forward!
[ebp] ax mov,
ret,
@@ -731,7 +598,7 @@ pc ( loop )
\ same contents
dx 5 i) add, \ word
[ebp] dx mov,
- xwordlbl findmod abs>rel jmp,
+ xwordlbl findmod absjmp,
L2 forward! ( skip2 )
cl al mov,
L1 forward! ( skip1 )
@@ -750,12 +617,12 @@ xcode (wnf)
wcall, rtype
cx 15 i) mov,
si ( pc ) i) mov,
- lblerrmsg abs>rel jmp,
+ lblerrmsg absjmp,
xcode ' ( "name" -- w )
wcall, word
dx lblsysdict m) mov,
- lblfind abs>rel call,
+ lblfind abscall,
[ebp]z?
xwordlbl (wnf) abs>rel jz,
ret,
@@ -833,7 +700,7 @@ xcode parse ( str -- n? f )
lblparseud abs>rel jnz,
si inc,
cx dec,
- lblparseud abs>rel call,
+ lblparseud abscall,
[ebp]z?
L1 abs>rel jz, \ fail
bp CELLSZ d) neg,
@@ -868,41 +735,195 @@ xcode ,"
ax ax test,
lblret abs>rel js,
xwordlbl ," i) push,
- lblcwrite abs>rel jmp,
+ lblcwrite absjmp,
pc to lblnextmeta 0 ,
xcode nextmeta
lblnextmeta pspushN,
ret,
-\ binary for "bp 4 i) sub, [ebp] XXXX i) mov," is 83 ed 04 c7 45 00 XX XX XX XX
+pc 6 nc, $83 $ed $04 $c7 $45 $00 ( XX ) \ bp 4 i) sub, [ebp] XX i) mov,
xcode litn
- ax $c704ed83 i) mov,
- lblwrite abs>rel call,
- al $45 i) mov,
- lblcwrite abs>rel call,
- al al xor,
- lblcwrite abs>rel call,
- xwordlbl , abs>rel jmp,
+ ( pc ) 6 movewrite,
+ xwordlbl , absjmp,
-pc
- lblcwrite abs>rel call,
- AX pspop, \ abs addr
+pc to lblcallwr \ bx=abs addr
+ al $e8 ( call ) i) mov,
+ lblcwrite abscall,
+ ax bx mov,
+pc to lblrelwr \ ax=abs addr
ax lblhere m) sub, \ displacement
ax 4 i) sub, \ ... from *after* call op
- lblwrite abs>rel jmp,
+ lblwrite absjmp,
xcode execute,
- al $e8 ( call ) i) mov,
- dup ( pc ) abs>rel jmp,
+ BX pspop,
+ lblcallwr absjmp,
xcode alias,
- al $e9 ( call ) i) mov,
- ( pc ) abs>rel jmp,
+ al $e9 ( jmp ) i) mov,
+ lblcwrite abscall,
+ AX pspop,
+ lblrelwr absjmp,
xcode exit,
al $c3 ( ret ) i) mov,
- lblcwrite abs>rel jmp,
+ lblcwrite absjmp,
+
+pc 2 nc, $89 $e7 \ di sp mov,
+xcode RSP>A,
+ ( pc ) 2 movewrite, ret,
+
+pc 2 nc, $89 $ef \ di bp mov,
+xcode PSP>A,
+ ( pc ) 2 movewrite, ret,
+
+xcode LIT>A, \ di XX i) mov, --> BF XX
+ al $bf i) mov, lblcwrite abscall,
+ xwordlbl , absjmp,
+
+pc 6 nc, $8b $7d $00 $83 $c5 $04 \ di [ebp] mov, [ebp] 4 i) add,
+xcode >A, \ di [ebp] mov, [ebp] 4 i) add, --> 8b 7d 00 83 c5 04
+ ( pc ) 6 movewrite, ret,
+
+pc 6 nc, $83 $ed $04 $89 $7d $00 \ [ebp] 4 i) sub, [ebp] di mov,
+xcode A>,
+ ( pc ) 6 movewrite, ret,
+
+pc 2 nc, $81 $c7 ( XX ) \ di XX i) add,
+xcode A+,
+ ( pc ) 2 movewrite,
+ xwordlbl , absjmp,
+
+pc 2 nc, $81 $07 ( XX ) \ di 0 d) XX i) add,
+xcode [A]+,
+ ( pc ) 2 movewrite,
+ xwordlbl , absjmp,
+
+pc to L1 \ 8b A@
+ al di 0 d) movclr,
+ AX pspush,
+ ret,
+pc 0 , EMETA_8B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ 16b A@
+ 16b! ax di 0 d) movclr,
+ AX pspush,
+ ret,
+pc nextmeta ! ( pc ) , EMETA_16B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ A@
+ ax di 0 d) mov,
+ AX pspush,
+ ret,
+xcode A@,
+ bx L1 i) mov, lblcallwr absjmp,
+
+pc to L1 \ 8b A!
+ AX pspop,
+ di 0 d) al mov,
+ ret,
+pc 0 , EMETA_8B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ 16b A!
+ AX pspop,
+ 16b! di 0 d) ax mov,
+ ret,
+pc nextmeta ! ( pc ) , EMETA_16B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ A!
+ AX pspop,
+ di 0 d) ax mov,
+ ret,
+xcode A!,
+ bx L1 i) mov, lblcallwr absjmp,
+
+pc to L1 \ 8b A@!
+ ax ax xor,
+ al [ebp] mov,
+ al di 0 d) xchg,
+ [ebp] ax mov,
+ ret,
+pc 0 , EMETA_8B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ 16b A@!
+ ax ax xor,
+ 16b! ax [ebp] mov,
+ 16b! ax di 0 d) xchg,
+ [ebp] ax mov,
+ ret,
+pc nextmeta ! ( pc ) , EMETA_16B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ A@!
+ ax [ebp] mov,
+ ax di 0 d) xchg,
+ [ebp] ax mov,
+ ret,
+xcode A@!,
+ bx L1 i) mov, lblcallwr absjmp,
+
+pc to L1 \ 8b A+!
+ AX pspop,
+ di 0 d) al add,
+ ret,
+pc 0 , EMETA_8B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ 16b A+!
+ AX pspop,
+ 16b! di 0 d) ax add,
+ ret,
+pc nextmeta ! ( pc ) , EMETA_16B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ A+!
+ AX pspop,
+ di 0 d) ax add,
+ ret,
+xcode A+!,
+ bx L1 i) mov, lblcallwr absjmp,
+
+pc to L1 \ 8b [A]@
+ bx di 0 d) mov,
+ al bx 0 d) movclr,
+ AX pspush,
+ ret,
+pc 0 , EMETA_8B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ 16b [A]@
+ bx di 0 d) mov,
+ 16b! ax bx 0 d) movclr,
+ AX pspush,
+ ret,
+pc nextmeta ! ( pc ) , EMETA_16B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ [A]@
+ bx di 0 d) mov,
+ ax bx 0 d) mov,
+ AX pspush,
+ ret,
+xcode [A]@,
+ bx L1 i) mov, lblcallwr absjmp,
+
+pc to L1 \ 8b [A]!
+ bx di 0 d) mov,
+ AX pspop,
+ bx 0 d) al mov,
+ ret,
+pc 0 , EMETA_8B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ 16b [A]!
+ bx di 0 d) mov,
+ AX pspop,
+ 16b! bx 0 d) ax mov,
+ ret,
+pc nextmeta ! ( pc ) , EMETA_16B ,
+ bx L1 i) mov, lblcallwr absjmp,
+pc to L1 \ [A]!
+ bx di 0 d) mov,
+ AX pspop,
+ bx 0 d) ax mov,
+ ret,
+xcode [A]!,
+ bx L1 i) mov, lblcallwr absjmp,
xcode [ ximm
lblcompiling m) 0 i) mov,
@@ -918,19 +939,19 @@ xcode stack?
lblret abs>rel jna,
cx 15 i) mov,
si ( pc ) i) mov,
- lblerrmsg abs>rel jmp,
+ lblerrmsg absjmp,
pc to L2 \ find in sys dict
lblcurword pspushN,
dx lblsysdict m) mov,
- lblfind abs>rel call,
+ lblfind abscall,
[ebp]z?
xwordlbl (wnf) abs>rel jz,
ret,
pc to L1 \ execute imm word
wcall, execute
- xwordlbl stack? abs>rel jmp,
+ xwordlbl stack? absjmp,
xcode compword ( str -- )
wcall, parse
@@ -938,13 +959,13 @@ xcode compword ( str -- )
ax ax test,
xwordlbl litn abs>rel jnz, \ literal: jump to litn
\ not a literal, find and compile
- L2 abs>rel call,
+ L2 abscall,
ax [ebp] mov, \ w
ax dec,
8b! ax 0 d) $80 i) test,
L1 abs>rel jnz, \ immediate? execute
\ compile word
- xwordlbl execute, abs>rel jmp,
+ xwordlbl execute, absjmp,
xcode runword ( str -- ) pc w>e lblsysdict pc>addr !
lblcompiling m) -1 i) test,
@@ -954,16 +975,16 @@ xcode runword ( str -- ) pc w>e lblsysdict pc>addr !
ax ax test,
xwordlbl noop abs>rel jnz, \ literal: nothing to do
\ not a literal, find and execute
- L2 abs>rel call,
+ L2 abscall,
AX pspop,
ax call,
- xwordlbl stack? abs>rel jmp,
+ xwordlbl stack? absjmp,
xcode main
lblmainalias forward!
pc ( loop )
wcall, word
wcall, runword
- ( pc ) abs>rel jmp,
+ ( pc ) absjmp,
pc lblbootptr pc>addr !
diff --git a/posix/dis.c b/posix/dis.c
@@ -19,7 +19,7 @@ struct op {
int arg;
};
-#define OPCNT 0x6b
+#define OPCNT 0x6c
static struct op ops[OPCNT] = {
{"JUMP", ARGINT},
{"CALL", ARGINT},
@@ -35,17 +35,17 @@ static struct op ops[OPCNT] = {
{"SLIT", ARGSTR},
{"BR", ARGINT},
{"CBR", ARGINT},
- {"NEXT", ARGINT},
{NULL, ARGERR},
+ {"YIELD", ARGNONE},
{"PSADD", ARGBYTE},
{"PSADDWR", ARGNONE},
- {"PSADDR", ARGBYTE},
- {"PSADDRWR", ARGNONE},
+ {NULL, ARGERR},
+ {NULL, ARGERR},
{"BOOTRD", ARGNONE},
{"STDOUT", ARGNONE},
- {"KEY", ARGNONE},
- {NULL, ARGERR},
+ {"MAYBEKEY", ARGNONE},
+ {"FINDMETA", ARGNONE},
{"DUP", ARGNONE},
{"CDUP", ARGNONE},
{"SWAP", ARGNONE},
@@ -57,29 +57,29 @@ static struct op ops[OPCNT] = {
{"RSADD", ARGINT},
{"RSADDWR", ARGNONE},
- {"RSADDR", ARGINT},
- {"RSADDRWR", ARGNONE},
+ {NULL, ARGERR},
+ {NULL, ARGERR},
{"SCNT", ARGNONE},
{"RCNT", ARGNONE},
- {"SET16B", ARGNONE},
- {"SET8B", ARGNONE},
- {"FETCH", ARGNONE},
- {"STORE", ARGNONE},
- {"ADDSTORE", ARGNONE},
- {"FETCHSTORE", ARGNONE},
- {"FETCHADD", ARGNONE},
- {"STOREADD", ARGNONE},
- {"IFETCHADD", ARGNONE},
- {"ISTOREADD", ARGNONE},
+ {"RSP2A", ARGNONE},
+ {"PSP2A", ARGNONE},
+ {"AFETCH", ARGNONE},
+ {"ASTORE", ARGNONE},
+ {"AADDSTORE", ARGNONE},
+ {NULL, ARGERR},
+ {"AINC", ARGINT},
+ {"AIINC", ARGINT},
+ {"AIFETCH", ARGNONE},
+ {"AISTORE", ARGNONE},
{"WRITE", ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
+ {"SRD", ARGNONE},
+ {"SWR", ARGNONE},
{"SETBW", ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
+ {"SETA", ARGNONE},
+ {"PUSHA", ARGNONE},
+ {"GETBW", ARGNONE},
+ {"LITA", ARGNONE},
{"INC", ARGNONE},
{"DEC", ARGNONE},
{"ADD", ARGNONE},
@@ -87,7 +87,7 @@ static struct op ops[OPCNT] = {
{"MUL", ARGNONE},
{"DIVMOD", ARGNONE},
{"AND", ARGNONE},
- {NULL, ARGNONE},
+ {"ALIGN4", ARGNONE},
{"OR", ARGNONE},
{"XOR", ARGNONE},
@@ -98,12 +98,12 @@ static struct op ops[OPCNT] = {
{"SHRC", ARGNONE},
{"LSHIFT", ARGNONE},
{"RSHIFT", ARGNONE},
- {"LITN", ARGNONE},
- {"EXECUTEWR", ARGNONE},
- {"EXITWR", ARGNONE},
+ {NULL, ARGERR},
+ {NULL, ARGERR},
+ {NULL, ARGERR},
{"MOVE", ARGNONE},
{"MOVEWR", ARGNONE},
- {"RTYPE", ARGNONE},
+ {"FINDMOD", ARGNONE},
{"WNF", ARGNONE},
{"STACKCHK", ARGNONE},
@@ -114,14 +114,14 @@ static struct op ops[OPCNT] = {
{"FIND", ARGNONE},
{"APOS", ARGNONE},
{"COMPILING", ARGNONE},
- {"SWR", ARGNONE},
+ {"ALIASWR", ARGNONE},
{"STARTCOMP", ARGNONE},
{"STOPCOMP", ARGNONE},
{"COMPWORD", ARGNONE},
{"RUNWORD", ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
+ {"USLEEP", ARGNONE},
+ {NULL, ARGERR},
+ {NULL, ARGERR},
{"FCHILD", ARGNONE},
{"FOPEN", ARGNONE},
@@ -129,9 +129,10 @@ static struct op ops[OPCNT] = {
{"FCLOSE", ARGNONE},
{"FINFO", ARGNONE},
{"FITER", ARGNONE},
- {NULL, ARGNONE},
- {NULL, ARGNONE},
+ {NULL, ARGERR},
+ {"FSEEK", ARGNONE},
{"MOUNTDRV", ARGNONE},
+ {"UNMOUNTDRV", ARGNONE},
{"DRVRD", ARGNONE},
{"DRVWR", ARGNONE}};
diff --git a/posix/vm.c b/posix/vm.c
@@ -40,6 +40,7 @@ struct VM {
dword PSP;
dword RSP;
dword PC; // when PC >= MEMSZ, machine is halted
+ dword A;
byte compiling;
byte bwidth; // 0=32bit 1=16bit 2=8bit
byte mem[MEMSZ];
@@ -261,16 +262,6 @@ static void PSADDWR() { // op: 11
cwrite(n);
}
-static void PSADDR() { // op: 12
- ppush(vm.PSP+gpcb());
-}
-
-static void PSADDRWR() { // op: 13
- dword n = ppop();
- cwrite(0x12); // PSADDR
- cwrite(n);
-}
-
static void BOOTRD() { // op: 14
ppush(fgetc(fp));
}
@@ -353,16 +344,6 @@ static void RSADDWR() { // op: 21
sd(_RCNT_, gd(_RCNT_)+n);
}
-static void RSADDR() { // op: 22
- ppush(vm.RSP+gpc());
-}
-
-static void RSADDRWR() { // op: 23
- dword n = ppop();
- cwrite(0x22); // RSADDR
- dwrite(n);
-}
-
static void SCNT() { // op: 24
ppush((PSTOP-vm.PSP)>>2);
}
@@ -371,69 +352,58 @@ static void RCNT() { // op: 25
ppush(((RSTOP-vm.RSP)>>2)-1);
}
-static void YIELDWR() { // op: 26
- cwrite(0x0f); // YIELD
+static void RSP2A() { // op: 26
+ vm.A = vm.RSP;
+}
+
+static void PSP2A() { // op: 27
+ vm.A = vm.PSP;
}
-static void FETCH() { // op: 28
- ppush(gv(ppop()));
+static void AFETCH() { // op: 28
+ ppush(gv(vm.A));
vm.bwidth = 0;
}
-static void STORE() { // op: 29
- dword a = ppop();
- sv(a, ppop());
+static void ASTORE() { // op: 29
+ sv(vm.A, ppop());
vm.bwidth = 0;
}
-static void ADDSTORE() { // op: 2a
- dword a = ppop();
- sv(a, gv(a)+ppop());
+static void AADDSTORE() { // op: 2a
+ sv(vm.A, gv(vm.A)+ppop());
vm.bwidth = 0;
}
-static void FETCHSTORE() { // op: 2b
- dword a = ppop();
+static void AFETCHSTORE() { // op: 2b
dword n = ppop();
- ppush(gv(a));
- sv(a, n);
+ ppush(gv(vm.A));
+ sv(vm.A, n);
vm.bwidth = 0;
}
-static void FETCHADD() { // op: 2c
- dword a = ppop();
- ppush(a+bwidth());
- ppush(gv(a));
- vm.bwidth = 0;
+static void AINC() { // op: 2c
+ vm.A += gpc();
}
-static void STOREADD() { // op: 2d
- dword a = ppop();
- sv(a, ppop());
- ppush(a+bwidth());
- vm.bwidth = 0;
+static void AIINC() { // op: 2d
+ sd(vm.A, gd(vm.A)+gpc());
}
-// ( a -- n )
-static void IFETCHADD() { // op: 2e
- dword a = ppop();
- ppush(gv(gd(a)));
- sd(a, gd(a)+bwidth());
+static void AIFETCH() { // op: 2e
+ ppush(gv(gd(vm.A)));
vm.bwidth = 0;
}
-// ( n a -- )
-static void ISTOREADD() { // op: 2f
- dword a = ppop();
- dword n = ppop();
- sv(gd(a), n);
- sd(a, gd(a)+bwidth());
+static void AISTORE() { // op: 2f
+ sv(gd(vm.A), ppop());
vm.bwidth = 0;
}
static void WRITE() { // op: 30
- ppush(HERE);
- ISTOREADD();
+ sv(here(), ppop());
+ allot(bwidth());
+ vm.bwidth = 0;
}
#define ESCAPECNT 3
@@ -466,10 +436,26 @@ static void SWR() { // op: 32
}
}
-static void SETBW() { // op: 34
+static void SETBW() { // op: 33
vm.bwidth = ppop();
}
+static void SETA() { // op: 34
+ vm.A = ppop();
+}
+
+static void PUSHA() { // op: 35
+ ppush(vm.A);
+}
+
+static void GETBW() { // op: 36
+ ppush(vm.bwidth);
+}
+
+static void LITA() { // op: 37
+ vm.A = gpc();
+}
+
static void INC() { // op: 38
ppush(ppop()+1);
}
@@ -560,18 +546,6 @@ static void RSHIFT() { // op: 48
ppush(n>>u);
}
-static void LITN() { // op: 49
- litwr(ppop());
-}
-
-static void EXECUTEWR() { // op: 4a
- callwr(ppop());
-}
-
-static void EXITWR() { // op: 4b
- retwr();
-}
-
static void MOVE() { // op: 4c
dword u = ppop();
dword dst = ppop();
@@ -735,7 +709,7 @@ static void STOPCOMP() { // op: 5a
static void COMPWORD() { // op: 5b
PARSE();
if (ppop()) {
- LITN();
+ litwr(ppop());
} else {
ppush(CURWORD);
ppush(sysdict());
@@ -745,7 +719,7 @@ static void COMPWORD() { // op: 5b
callword(ppop());
STACKCHK();
} else {
- EXECUTEWR();
+ callwr(ppop());
}
}
}
@@ -1051,14 +1025,14 @@ static void DRVWR() { // op: 6b
static void (*ops[OPCNT])() = {
JUMP, CALL, RET, LIT, BYE, BYEFAIL, QUIT, ABORT_,
EXECUTE, CELL, DOES, SLIT, BR, CBR, NULL, YIELD,
- PSADD, PSADDWR, PSADDR, PSADDRWR, BOOTRD, STDOUT, MAYBEKEY, FINDMETA,
+ PSADD, PSADDWR, NULL, NULL, BOOTRD, STDOUT, MAYBEKEY, FINDMETA,
DUP, CDUP, SWAP, OVER, ROT, ROTR, NIP, TUCK,
- RSADD, RSADDWR, RSADDR, RSADDRWR, SCNT, RCNT, YIELDWR, NULL,
- FETCH, STORE, ADDSTORE, FETCHSTORE, FETCHADD, STOREADD, IFETCHADD, ISTOREADD,
- WRITE, SRD, SWR, NULL, SETBW, NULL, NULL, NULL,
+ RSADD, RSADDWR, NULL, NULL, SCNT, RCNT, RSP2A, PSP2A,
+ AFETCH, ASTORE, AADDSTORE, AFETCHSTORE, AINC, AIINC, AIFETCH, AISTORE,
+ WRITE, SRD, SWR, SETBW, SETA, PUSHA, GETBW, LITA,
INC, DEC, ADD, SUB, MUL, DIVMOD, AND, ALIGN4,
OR, XOR, BOOL, NOT, LT, SHLC, SHRC, LSHIFT,
- RSHIFT, LITN, EXECUTEWR, EXITWR, MOVE, MOVEWR, FINDMOD, WNF,
+ RSHIFT, NULL, NULL, NULL, MOVE, MOVEWR, FINDMOD, WNF,
STACKCHK, MAYBEWORD, WORD, PARSE, REQ, FIND, APOS, COMPILING,
ALIASWR, STARTCOMP, STOPCOMP, COMPWORD, RUNWORD, USLEEP, NULL, NULL,
FCHILD, FOPEN, FREADBUF, FCLOSE, FINFO, FITER, NULL, FSEEK,
@@ -1067,14 +1041,14 @@ static void (*ops[OPCNT])() = {
static char *opnames[OPCNT] = {
NULL, NULL, NULL, NULL, "bye", "byefail", "quit", "(abort)",
"execute", "(cell)", "(does)", "(s)", "(br)", "(?br)", NULL, NULL,
- NULL, "p+,", NULL, "p',", "boot<", "(emit)", "(key?)", "findmeta",
+ NULL, "p+,", NULL, NULL, "boot<", "(emit)", "(key?)", "findmeta",
"dup", "?dup", "swap", "over", "rot", "rot>", "nip", "tuck",
- NULL, "r+,", NULL, "r',", "scnt", "rcnt", "yield", NULL,
- "@", "!", "+!", "@!", "@+", "!+", "@@+", "@!+",
+ NULL, "r+,", NULL, NULL, "scnt", "rcnt", NULL, NULL,
+ NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
",", "\"<", ",\"", NULL, NULL, NULL, NULL, NULL,
"1+", "1-", "+", "-", "*", "/mod", "and", "align4",
"or", "xor", "bool", "not", "<", "<<c", ">>c", "lshift",
- "rshift", "litn", "execute,", "exit,", "move", "move,", "findmod", "(wnf)",
+ "rshift", NULL, NULL, NULL, "move", "move,", "findmod", "(wnf)",
"stack?", "maybeword", "word", "parse", "[]=", "find", "'", "compiling",
"alias,", "]", "[", "compword", "runword", "_usleep", NULL, NULL,
"_fchild", "_fopen", "_freadbuf", "_fclose", "_finfo", "_fiter", NULL, "_fseek",
@@ -1111,23 +1085,19 @@ static void opentry(byte op) {
retwr();
}
-// Entry with "binary width matrix" built in.
-static void bwentry(byte op) {
+static void setbwwr(byte bw) { litwr(bw); cwrite(0x33); }
+
+// Make current entry "binary width" modulable
+static void makebw() {
+ dword current = sysdict() + 5;
dword a = here();
dwrite(0); dwrite(0x10); // EMETA_8B
- litwr(2);
- cwrite(0x34); // SETBW
- cwrite(op);
- retwr();
- sd(NEXTMETA, here());
+ setbwwr(2);
+ jumpwr(current);
+ sd(sysdict()-4, here());
dwrite(a); dwrite(0x11); // EMETA_16B
- litwr(1);
- cwrite(0x34); // SETBW
- cwrite(op);
- retwr();
- entry(opnames[op]);
- cwrite(op);
- retwr();
+ setbwwr(1);
+ jumpwr(current);
}
static void makeimm(char *name) {
dword a = find(name)-1;
@@ -1145,6 +1115,19 @@ static void sysalias(char *name, char *target) {
jumpwr(find(target));
}
+static void asetwr() { cwrite(0x34); }
+static void writewr() { cwrite(0x30); }
+
+static void compileop(byte op) {
+ litwr(op);
+ callwr(find("c,"));
+}
+static void keepbwwr() {
+ cwrite(0x36); // GETBW
+ callwr(find("litn"));
+ compileop(0x33); // SETBW
+}
+
static void buildsysdict() {
sd(HERE, 0);
sd(HEREMAX, IOBUF);
@@ -1153,16 +1136,35 @@ static void buildsysdict() {
sd(SYSDICT, 0);
sd(SYSDICT+4, 0); // set 0 len byte. See doc/impl
entry("noop"); retwr();
- for (int i=0x04; i<0x28; i++) {
- if (ops[i] && opnames[i]) { opentry(i); }
- }
- for (int i=0x28; i<0x31; i++) { bwentry(i); }
- entry("c@"); litwr(2); cwrite(0x34); cwrite(0x28); retwr();
- entry("c!"); litwr(2); cwrite(0x34); cwrite(0x29); retwr();
- entry("c,"); litwr(2); cwrite(0x34); cwrite(0x30); retwr();
- for (int i=0x31; i<OPCNT; i++) {
- if (ops[i] && opnames[i]) { opentry(i); }
+ for (int i=0x04; i<OPCNT; i++) {
+ if (ops[i] && opnames[i]) {
+ opentry(i);
+ if (i==0x30) makebw();
+ }
}
+ entry("@"); asetwr(); cwrite(0x28); retwr(); makebw();
+ entry("!"); asetwr(); cwrite(0x29); retwr(); makebw();
+ entry("+!"); asetwr(); cwrite(0x2a); retwr(); makebw();
+ entry("c@"); setbwwr(2); asetwr(); cwrite(0x28); retwr();
+ entry("c!"); setbwwr(2); asetwr(); cwrite(0x29); retwr();
+ entry("c,"); setbwwr(2); writewr(); retwr();
+ entry("litn"); compileop(0x03); writewr(); retwr();
+ entry("execute,"); compileop(0x01); writewr(); retwr();
+ entry("exit,"); compileop(0x02); retwr();
+ entry("yield"); compileop(0x0f); retwr();
+ entry("RSP>A,"); compileop(0x26); retwr();
+ entry("PSP>A,"); compileop(0x27); retwr();
+ entry("A@,"); keepbwwr(); compileop(0x28); retwr(); makebw();
+ entry("A!,"); keepbwwr(); compileop(0x29); retwr(); makebw();
+ entry("A+!,"); keepbwwr(); compileop(0x2a); retwr(); makebw();
+ entry("A@!,"); keepbwwr(); compileop(0x2b); retwr(); makebw();
+ entry("A+,"); compileop(0x2c); writewr(); retwr();
+ entry("[A]+,"); compileop(0x2d); writewr(); retwr();
+ entry("[A]@,"); keepbwwr(); compileop(0x2e); retwr(); makebw();
+ entry("[A]!,"); keepbwwr(); compileop(0x2f); retwr(); makebw();
+ entry(">A,"); compileop(0x34); retwr();
+ entry("A>,"); compileop(0x35); retwr();
+ entry("LIT>A,"); compileop(0x37); writewr(); retwr();
makeimm("[");
makeimm("yield");
sysalias("abort", "byefail");
@@ -1183,8 +1185,7 @@ static void buildsysdict() {
mainaddr = here();
callwr(find("word"));
callwr(find("runword"));
- cwrite(0x00); // JUMP
- dwrite(mainaddr);
+ jumpwr(mainaddr);
}
// Interpret loop
