duskos

commit 3af7751e997c2aa02a8d12f0fbd6abbf9b333f8a
parent 5a365c6e0cccc9fbc686abd9125a670c41aff994
Author: Virgil Dupras <hsoft@hardcoded.net>
Date:   Thu,  1 Dec 2022 21:39:28 -0500

comp/c: allow string literals to be assigned to global vars

I'm quite happy about my "literena" idea, I think it's a good one. Much less
hackish than wrapping jumps around all literals...

Diffstat:
M
fs/comp/c/pgen.fs
 | 
39
+++++++++++++++++++++++----------------
M
fs/comp/c/vm/forth.fs
 | 
3
+--
M
fs/comp/c/vm/i386.fs
 | 
3
+--
M
fs/tests/comp/c/test.c
 | 
4
+++-

4 files changed, 28 insertions(+), 21 deletions(-)
diff --git a/fs/comp/c/pgen.fs b/fs/comp/c/pgen.fs
@@ -6,12 +6,24 @@ require /sys/scratch.fs
 ?f<< /lib/str.fs
 ?f<< /lib/wordtbl.fs
 ?f<< /lib/stack.fs
+?f<< /lib/arena.fs
 ?f<< /comp/c/tok.fs
 ?f<< /comp/c/type.fs
 \ This unit also requires vm/(ARCH).fs, but it's loaded in comp/c/cc.fs
 
+\ This arena is for *runtime* string and array literals. We use an arena rather
+\ than writing directly to here because at the time when we want to write the
+\ literal, we might be in the middle of code generation. This arena, which is
+\ never resetted, gives us a safe space to write literals. The idea is that at
+\ the prelude of each function prelude, we call :reserve to ensure that we
+\ won't allocate a new arena in the middle of the function (this might fail if a
+\ single function allocates more than ARENASZ bytes of literals).
+Arena :new structbind Arena _litarena
+
 \ Maximum number that a function call can have
 $10 const MAXARGCNT
+\ Maximum size in bytes that a single literal can have
+$400 const MAXLITSZ
 
 1 value _ccdebug
 : _err ( -- ) tokdbg abort" pgen error" ;
@@ -235,17 +247,14 @@ alias noop parseFactor ( tok -- ) \ forward declaration
     r@ to nexttputback
   endcase ;
 
-$400 const CONSTARRAYBUFSZ
-create _constarray CONSTARRAYBUFSZ allot
-: _!+ ( sz -- ) case 1 of = c!+ endof 2 of = 16b !+ endof !+ endcase ;
-: parseList ( typesize -- ) >r \ V1=typesize
-  _constarray CELLSZ + begin ( ctype a )
+: _, ( sz -- ) case 1 of = c, endof 2 of = 16b , endof , endcase ;
+: parseList ( typesize -- )
+  MAXLITSZ _litarena :[ 0 , begin ( typesize )
     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 ;
+    vmop arg vmop :init over _, ( )
+    ',' readChar? not until ( typesize tok )
+  '}' expectChar drop ( ) here _litarena :] ( end start )
+  tuck - CELLSZ - ( start len ) over ! constarray>op ;
 
 \ A factor can be:
 \ 1. A constant
@@ -265,11 +274,9 @@ create _constarray CONSTARRAYBUFSZ allot
         nip parseDeclarator drop read) nextt parseFactor
         else ( tok ) parseExpression read) parsePostfixOp then
     endof
-    '"' of isChar?^
-      vmjmp[, here ( jaddr saddr )
-      here 0 c, ['] ," with-stdin< here over - 1- swap c! ( jaddr saddr )
-      const>op ]vmjmp
-    endof
+    '"' of isChar?^ MAXLITSZ _litarena :[
+      here 0 c, ['] ," with-stdin< here over - 1- swap c! ( saddr )
+      _litarena :] const>op endof
     '{' of isChar?^ \ vmop^ must be set to target for list
       vmop^ :hasop# vmop^ type *ariunitsz parseList endof
     S" pspop" of s= read( read) vmpspop, parsePostfixOp endof
@@ -398,7 +405,7 @@ current to parseStatement
   dup _locvars CType :append repeat ( ctype tok ) 2drop ;
 
 : parseFunction ( ctype -- )
-  dup addSymbol 0 to _locvars 0 to _initcode to _curfunc ( )
+  dup addSymbol 0 to _locvars 0 to _initcode to _curfunc _litarena :reserve ( )
   \ Let's parse function body
   nextt '{' expectChar begin ( )
     nextt dup parseType while ( tok type ) nip parseDeclLine repeat ( tok )
diff --git a/fs/comp/c/vm/forth.fs b/fs/comp/c/vm/forth.fs
@@ -134,8 +134,7 @@ ARIOPCNT 1+ ( for = ) wordtbl _tbl
 : _movarray, \ special case, we have a {1, 2, 3} assign
   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
+  swap 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
diff --git a/fs/comp/c/vm/i386.fs b/fs/comp/c/vm/i386.fs
@@ -234,8 +234,7 @@ ASSIGNOPCNT wordtbl _tbl
 : _movarray
   vmop loc VM_STACKFRAME = _assert
   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,
+  cx i) mov, si i) mov, di vmop :compile mov,
   rep, movsb, ;
 
 : assignop, ( opid -- )
diff --git a/fs/tests/comp/c/test.c b/fs/tests/comp/c/test.c
@@ -165,8 +165,9 @@ int funcsig(int a, int b) {
     return fn(a, b);
 }
 
+static char *msg = "Hello World!";
 void helloworld() {
-    stype("Hello World!");
+    stype(msg);
 }
 int forsum(int n) {
     int i;
@@ -183,6 +184,7 @@ unsigned int multret(unsigned int x) {
         return x-10;
     }
 }
+
 void multretvoid(unsigned int x) {
     if (x == 42) {
         stype("Answer to the universe");