duskos

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

commit 51064d6055e25bbc86d9264b0d826d1b9e94f4d5
parent 3f8089635d64578eec2b5116b0aa73af15fb3ff9
Author: Virgil Dupras <hsoft@hardcoded.net>
Date:   Sun,  4 Sep 2022 14:33:14 -0400

cc: improve forth vm

It now succeeds through the 4 first tests of tests/cc/vm.

Diffstat:
MMakefile | 2+-
Mfs/cc/cc.fs | 9+++------
Mfs/cc/vm/common.fs | 5-----
Mfs/cc/vm/forth.fs | 55++++++++++++++++++++++++++++++++++++++++++++-----------
Mfs/cc/vm/i386.fs | 7+++++++
Afs/cc/vm/vm.fs | 5+++++
Mfs/doc/dict.txt | 2++
Mfs/tests/cc/vm.fs | 2+-
Mfs/xcomp/bootlo.fs | 3++-
Mfs/xcomp/i386.fs | 33++++++++++++++++++++++++++-------
Mposix/init.fs | 2+-
Mposix/vm.c | 51++++++++++++++++++++++++++++++++++-----------------
12 files changed, 126 insertions(+), 50 deletions(-)

diff --git a/Makefile b/Makefile @@ -39,7 +39,7 @@ test: dusk # temporary while developing the Forth CC VM. .PHONY: testvm testvm: dusk - echo "' byefail to abort f<< /cc/vm/forth.fs f<< tests/cc/vm.fs bye" | ./dusk || (echo; exit 1) + echo "' byefail to abort f<< tests/cc/vm.fs bye" | ./dusk || (echo; exit 1) .PHONY: clean clean: diff --git a/fs/cc/cc.fs b/fs/cc/cc.fs @@ -1,12 +1,9 @@ \ C compiler -require sys/scratch.fs require sys/xhere.fs 1 value _debug -S" /cc/vm" curpath :find# ( path ) -syspad :[ ARCH c@+ dup 3 + c, move, ," .fs" syspad :] ( path fname ) -swap Path :child dup bool const HASCC ( path ) -HASCC not [if] drop ." Unsupported arch for CC" nl> \s [then] -( path ) Path :fload +ARCH S" forth" s= not const HASCC +HASCC not [if] ." Unsupported arch for CC" nl> \s [then] +?f<< /cc/vm/vm.fs ?f<< /cc/gen.fs \ Compiles input coming from the stdin alias and writes the diff --git a/fs/cc/vm/common.fs b/fs/cc/vm/common.fs @@ -13,12 +13,10 @@ $00 const VM_NONE $01 const VM_CONSTANT \ 42 $02 const VM_STACKFRAME \ esp+x -$04 const VM_REGISTER \ eax $05 const VM_CONSTARRAY \ pointer to an array with the 1st elem being length $11 const VM_*CONSTANT \ [1234] $12 const VM_*STACKFRAME \ [esp+x] $13 const VM_*ARGSFRAME \ [ebp+x] -$14 const VM_*REGISTER \ [eax] \ 2 operands, 2 fields each (type, arg), 4b per field create operands 16 allot0 @@ -46,9 +44,6 @@ operands value 'curop : ps+>op ( off -- ) noop# VM_*ARGSFRAME optype! oparg! ; : mem>op ( n -- ) noop# VM_*CONSTANT optype! oparg! ; -\ get current operand SF offset, adjusted with callsz -: opsf+ ( -- off ) oparg callsz + ; - : oppush ( -- oparg optype ) oparg optype VM_NONE optype! ; : oppop ( oparg optype -- ) noop# optype! oparg! ; diff --git a/fs/cc/vm/forth.fs b/fs/cc/vm/forth.fs @@ -4,9 +4,16 @@ \ the advantage of working under any architecture. ?f<< /cc/vm/common.fs -$06 const VM_TOS \ op is on current TOS. Only one of them can have this type. +\ Operands that are specific to this VM +$04 const VM_TOS \ op is on current TOS. Only one of them can have this type. -: opdeinit VM_NONE optype! ; +\ To simplify argframe management, we copy the args to the buffer below during +\ vmprelude, and then refer to this buffer whenever we need to. This way, when +\ comes the time to vmret, we can simply push the result to PS. +$40 const MAXARGSZ +create argsframe MAXARGSZ allot + +: opdeinit optype $f and VM_TOS = if 4 p+, then VM_NONE optype! ; : ops$ selop2 opdeinit selop1 opdeinit @@ -16,19 +23,36 @@ $06 const VM_TOS \ op is on current TOS. Only one of them can have this type. : op>PS ( -- ) optype case VM_CONSTANT of = oparg litn endof - VM_STACKFRAME of = abort" can't address VM_STACKFRAME directly" endof - VM_REGISTER of = abort" TODO" endof - VM_TOS of = endof - VM_*CONSTANT of = abort" TODO" endof - VM_*STACKFRAME of = abort" TODO" endof - VM_*ARGSFRAME of = abort" TODO" endof - VM_*REGISTER of = abort" TODO" endof + VM_STACKFRAME of = oparg r', endof + VM_TOS of = VM_NONE optype! endof + VM_*CONSTANT of = oparg litn compile @ endof + VM_*STACKFRAME of = oparg r', compile @ endof + VM_*ARGSFRAME of = argsframe oparg + litn compile @ endof + _err endcase ; + +\ if possible, transform current operand in its reference +: &op>op optype case + VM_*STACKFRAME of = VM_STACKFRAME optype! endof + VM_*CONSTANT of = VM_CONSTANT optype! endof + _err endcase ; + +\ if possible, dereference current operand +: *op>op optype case + VM_CONSTANT of = VM_*CONSTANT optype! endof + VM_*CONSTANT of = abort" TODO" endof + VM_STACKFRAME of = VM_*STACKFRAME optype! endof + VM_*STACKFRAME of = abort" TODO" endof + VM_*ARGSFRAME of = abort" TODO" endof + VM_TOS of = compile @ endof _err endcase ; \ generate function prelude code by allocating "locsz" bytes on RS. : vmprelude, ( argsz locsz -- ) - to locsz to argsz - locsz if neg r+, then ; + to locsz + ?dup if + 0 p', argsframe litn ( argsz ) dup litn compile move + ( argsz ) p+, then + locsz if locsz neg r+, then ; : binop doer ' , does> @ ( w ) selop1 op>PS selop2 hasop# op>PS @@ -39,9 +63,18 @@ binop vmadd, + binop vmsub, - binop vmmul, * +\ 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 +\ and the left part as op1. +: vmmov, + selop2 hasop# op>PS selop1 &op>op op>PS + compile ! + opdeinit selop2 opdeinit selop1 ; + \ deallocate locsz and argsz. If result is set, keep a 4b in here and push the \ result there. : vmret, selop2 noop# \ returning with a second operand? something's wrong locsz if locsz r+, then + selop1 optype if op>PS opdeinit then exit, ; diff --git a/fs/cc/vm/i386.fs b/fs/cc/vm/i386.fs @@ -43,6 +43,10 @@ ?f<< asm/i386.fs ?f<< /cc/vm/common.fs +\ Operands that are specific to this VM +$04 const VM_REGISTER \ eax +$14 const VM_*REGISTER \ [eax] + \ Register management \ When an operand needs to go to a register, we allocate one for it. when it \ doesn't need it anymore, we deallocate it. Registers have to be deallocated @@ -68,6 +72,9 @@ create registers AX c, BX c, CX c, DX c, SI c, DI c, \ reinitialize selected op to VM_NONE and dealloc registers if needed : opdeinit optype $f and VM_REGISTER = if regfree then VM_NONE optype! ; +\ get current operand SF offset, adjusted with callsz +: opsf+ ( -- off ) oparg callsz + ; + \ Deinit both ops and select Op1 : ops$ selop2 opdeinit selop1 opdeinit diff --git a/fs/cc/vm/vm.fs b/fs/cc/vm/vm.fs @@ -0,0 +1,5 @@ +require sys/scratch.fs + +S" /cc/vm" curpath :find# ( path ) +syspad :[ ARCH c@+ dup 3 + c, move, ," .fs" syspad :] ( path fname ) +swap Path :child Path :fload diff --git a/fs/doc/dict.txt b/fs/doc/dict.txt @@ -124,6 +124,8 @@ 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. diff --git a/fs/tests/cc/vm.fs b/fs/tests/cc/vm.fs @@ -1,5 +1,5 @@ ?f<< tests/harness.fs -?f<< cc/vm/i386.fs +?f<< cc/vm/vm.fs testbegin \ Tests for the C compiler VM module \ binop[+](binop[*](const[2],const[3]),const[1]) diff --git a/fs/xcomp/bootlo.fs b/fs/xcomp/bootlo.fs @@ -30,6 +30,7 @@ code : ] code ] ; : \ begin IN< @ execute $0a = until ; immediate \ hello, this is a comment! : exit exit, ; immediate +code drop 4 p+, exit, : ( begin word dup c@ 1 = if 1+ c@ ')' = if exit then else drop then @@ -40,7 +41,7 @@ code : ] code ] ; : r@ 0 r', compile @ ; immediate : r> [compile] r@ [compile] rdrop ; immediate : >r -4 r+, 0 r', compile ! ; immediate -: 2drop drop drop ; +code 2drop 8 p+, exit, : 2dup over over ; \ Arithmetic diff --git a/fs/xcomp/i386.fs b/fs/xcomp/i386.fs @@ -138,7 +138,7 @@ xcode execute AX pspop, ax jmp, -xcode drop +xcode drop \ we could remove it, but EMIT defaults to it... ps-, ret, @@ -583,21 +583,40 @@ xcode r+, ( n -- ) lbl[rcnt] m) ax add, lblcwrite abs>rel jmp, +\ 83 c5 XX --> add ebp, XX +pc 2 nc, $83 $c5 +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 6 nc, $83 $ed $04 $89 $45 $00 -\ 8d 44 24 XX --> lea eax, [esp+XX] -pc 3 nc, $8d $44 $24 -xcode r', ( n -- ) - si ( pc ) i) mov, +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, AX pspop, lblcwrite abs>rel call, - si ( pc ) i) mov, + 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, + xcode 16b ximm lblwoff m) $20 i) mov, ret, diff --git a/posix/init.fs b/posix/init.fs @@ -1,2 +1,2 @@ \ Initialization for POSIX Dusk -: ARCH S" none" ; +: ARCH S" forth" ; diff --git a/posix/vm.c b/posix/vm.c @@ -207,23 +207,23 @@ static void CELL() { // op: 09 ppush(rpop()); } -static void DOES() { // op: 0c +static void DOES() { // op: 0a dword a = rpop(); ppush(a+4); vm.PC = gd(a); } -static void SLIT() { // op: 0d +static void SLIT() { // op: 0b dword a = rpop(); ppush(a); vm.PC = a + gb(a) + 1; } -static void BR() { // op: 0e +static void BR() { // op: 0c vm.PC = gd(rpop()); } -static void CBR() { // op: 0f +static void CBR() { // op: 0d if (ppop()) { rpush(rpop()+4); } else { @@ -231,7 +231,7 @@ static void CBR() { // op: 0f } } -static void NEXT() { // op: 10 +static void NEXT() { // op: 0e dword r = rpop(); dword n = rpop(); if (--n) { @@ -242,11 +242,32 @@ static void NEXT() { // op: 10 } } -static void BOOTRD() { // op: 13 +static void PSADD() { // op: 10 + byte n = gpcb(); + vm.PSP += (char)n; +} + +static void PSADDWR() { // op: 11 + dword n = ppop(); + cwrite(0x10); // PSADD + 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)); } -static void STDOUT() { // op: 14 +static void STDOUT() { // op: 15 dword c = ppop(); write(STDOUT_FILENO, &c, 1); } @@ -255,10 +276,6 @@ static void KEY() { // op: 16 ppush(getc(stdin)); } -static void DROP() { // op: 17 - ppop(); -} - static void DUP() { // op: 18 ppush(ppeek()); } @@ -902,7 +919,7 @@ static void MOUNTDRV() { // op: 68 #define SECSZ 512 // ( sec dst drv -- ) static void DRVRD() { // op: 69 - DROP(); + ppop(); dword dst = ppop(); dword sec = ppop(); fseek(fp, SECSZ * sec, SEEK_SET); @@ -911,7 +928,7 @@ static void DRVRD() { // op: 69 // ( sec src drv -- ) static void DRVWR() { // op: 6a - DROP(); + ppop(); dword src = ppop(); dword sec = ppop(); fseek(fp, SECSZ * sec, SEEK_SET); @@ -921,8 +938,8 @@ static void DRVWR() { // op: 6a #define OPCNT 0x6b static void (*ops[OPCNT])() = { JUMP, CALL, RET, LIT, BYE, BYEFAIL, QUIT, ABORT_, - EXECUTE, CELL, NULL, NULL, DOES, SLIT, BR, CBR, - NEXT, NULL, NULL, BOOTRD, STDOUT, NULL, KEY, DROP, + EXECUTE, CELL, DOES, SLIT, BR, CBR, NEXT, NULL, + PSADD, PSADDWR, PSADDR, PSADDRWR, BOOTRD, STDOUT, KEY, NULL, DUP, CDUP, SWAP, OVER, ROT, ROTR, NIP, TUCK, RSADD, RSADDWR, RSADDR, RSADDRWR, SCNT, RCNT, SET16B, SET8B, FETCH, STORE, ADDSTORE, FETCHSTORE, FETCHADD, STOREADD, IFETCHADD, ISTOREADD, @@ -937,8 +954,8 @@ static void (*ops[OPCNT])() = { static char *opnames[OPCNT] = { NULL, NULL, NULL, NULL, "bye", "byefail", "quit", "(abort)", - "execute", "(cell)", NULL, NULL, "(does)", "(s)", "(br)", "(?br)", - "(next)", NULL, NULL, "boot<", "(emit)", NULL, "(key)", "drop", + "execute", "(cell)", "(does)", "(s)", "(br)", "(?br)", "(next)", NULL, + NULL, "p+,", NULL, "p',", "boot<", "(emit)", "(key)", "drop", "dup", "?dup", "swap", "over", "rot", "rot>", "nip", "tuck", NULL, "r+,", NULL, "r',", "scnt", "rcnt", "16b", "8b", "@", "!", "+!", "@!", "@+", "!+", "@@+", "@!+",