duskos

commit 18d90eef8d5046602150136d377784a69758e0ac
parent 15789cfd00ca5eebfc55a02a08eef12e1b1f6ebe
Author: Virgil Dupras <hsoft@hardcoded.net>
Date:   Mon,  8 May 2023 21:29:30 -0400

lib/alloc: add HERE locking mechanism

see doc/lib/alloc. Use this mechanism in comp/c.

I added this to try to find a bug I'm hunting, it turns out it's not this. But
the mechanism is still useful.

Diffstat:
M
fs/comp/c/egen.fs
 | 
2
++
M
fs/comp/c/gen.fs
 | 
6
+++---
M
fs/comp/c/type.fs
 | 
2
+-
M
fs/doc/lib/alloc.txt
 | 
18
++++++++++++++++++
M
fs/lib/alloc.fs
 | 
6
++++++
M
fs/lib/arena.fs
 | 
2
+-
M
fs/lib/malloc.fs
 | 
2
+-

7 files changed, 32 insertions(+), 6 deletions(-)
diff --git a/fs/comp/c/egen.fs b/fs/comp/c/egen.fs
@@ -17,6 +17,8 @@ require /sys/scratch.fs
 \ 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
+: egenreserve _litarena :reserve ;
+
 \ Maximum size in bytes that a single literal can have
 $400 const MAXLITSZ
 
diff --git a/fs/comp/c/gen.fs b/fs/comp/c/gen.fs
@@ -36,11 +36,11 @@ require /sys/scratch.fs
 \ declaration) and consume tokens until that element is finished parsing. That
 \ element is written to memory at "here".
 : cparse ( tok -- )
-  cctypereserve 0 to curstatic
+  typereserve egenreserve 0 to curstatic lockhere
   dup S" static" s= if drop nextt 1 to curstatic then
   parseType _assert ( type )
   ';' readChar? if \ Only a type on a line is fine, carry on
-    drop exit then to nexttputback
+    drop unlockhere exit then to nexttputback
   parseDeclarator ( cdecl )
   curstatic if dup CDecl :static! then
   _ccdebug if ." parsing: " dup printtype nl> then
@@ -50,4 +50,4 @@ require /sys/scratch.fs
         ." complete: " dup printtype nl> CDecl offset here over - spit nl>
         else drop then
       else parseFunctionProto then
-    else parseGlobalDecl then ( ) ;
+    else parseGlobalDecl then ( ) unlockhere ;
diff --git a/fs/comp/c/type.fs b/fs/comp/c/type.fs
@@ -15,7 +15,7 @@ Arena :new const _parena \ Permanent
 Arena :new const _tarena \ Temporary
 
 \ Call this in between code gen so that we don't have untimely block allocs.
-: cctypereserve _parena Arena :reserve _tarena Arena :reserve ;
+: typereserve _parena Arena :reserve _tarena Arena :reserve ;
 
 : _err ( -- ) abort" type error" ;
 : _assert ( f -- ) not if _err then ;
diff --git a/fs/doc/lib/alloc.txt b/fs/doc/lib/alloc.txt
@@ -76,3 +76,21 @@ Allocator API can be exposed to C by loading lib/alloc.h, which add these
 functions:
 
 int alloc_allot(unsigned int n, int self) --> :allot
+
+## Locking HERE
+
+There are cases where you're writing stuff to HERE which needs to stay
+contiguous at the same time as you're using words which might, or might not use
+dynamic allocation mechanism in a way that will result in an allocation to HERE
+that conflicts with your current work.
+
+This will generally corrupt your memory and cause bugs that are difficult to
+identify.
+
+To protect yourself from bugs that are difficult to pinpoint, you can "lock
+HERE" before you begin your operation. Then, any dynamic allocator that is about
+to allocate to HERE will check the lock and abort if it's taken. The API is:
+
+lockhere ( -- ) Take the lock
+unlockhere ( -- ) Release the lock
+herefree# ( -- ) If the lock is taken, abort with message
diff --git a/fs/lib/alloc.fs b/fs/lib/alloc.fs
@@ -1,3 +1,8 @@
+0 value _locked
+: herefree# _locked if 0 to _locked abort" allocating to locked HERE!" then ;
+: lockhere herefree# 1 to _locked ;
+: unlockhere 0 to _locked ;
+
 \ TODO: add the concept of "max allocation unit" to abort when we're allocating
 \ chunks that are too big. I got burned while working on asm/uxntal.c, chasing
 \ what I thought was a tricky memory corruption bug, but it just so happened
@@ -34,3 +39,4 @@ struct[ Allocator
   : :, ( n self -- a ) CELLSZ swap :allot tuck ! ;
   : :s, ( str self -- a ) swap c@+ rot :[]>str ;
 ]struct
+
diff --git a/fs/lib/arena.fs b/fs/lib/arena.fs
@@ -6,7 +6,7 @@ struct[ ArenaBuf
   sfield nextbuf
   SZ &+ buf
   : :)buf buf ARENASZ + ;
-  : :new ( -- buf ) here 0 , ARENASZ allot ;
+  : :new ( -- buf ) herefree# here 0 , ARENASZ allot ;
   : :next dup nextbuf ?dup not if :new tuck swap to nextbuf else nip then ;
 ]struct
 
diff --git a/fs/lib/malloc.fs b/fs/lib/malloc.fs
@@ -4,7 +4,7 @@ struct[ _Buf
   sfield used
   SZ &+ buf
   : :)buf bi buf | size + ;
-  : :new ( sz -- buf ) here 0 , over , 0 , swap allot ;
+  : :new ( sz -- buf ) herefree# here 0 , over , 0 , swap allot ;
   \ Find an unused buffer with a size >= "sz".
   : :find ( sz self -- buf-or-0 ) swap >r \ V1=sz
     begin dup while ( buf )