implement ALLOCATE and FREE using buddy allocator

startup.4th

@@ -28,6 +28,21 @@
 DEFER QUIT ( -- <noreturn> )
 ' BAILOUT ' QUIT DEFER!
 
+\ Standard (ANS FORTH) THROW code assignments (-255 ... -1)
+-1 CONSTANT EXCP-ABORT
+-2 CONSTANT EXCP-FAIL
+-3 CONSTANT EXCP-STACK-OVERFLOW
+-4 CONSTANT EXCP-STACk-UNDERFLOW
+-5 CONSTANT EXCP-RETURN-OVERFLOW
+-6 CONSTANT EXCP-RETURN-UNDERFLOW
+-8 CONSTANT EXCP-DICTIONARY-OVERFLOW
+-13 CONSTANT EXCP-UNDEFINED-WORD
+-24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT
+-37 CONSTANT EXCP-FILE-IO
+
+\ Non-standard system error codes (-4095 ... -256)
+-256 CONSTANT EXCP-HEAP-OVERFLOW
+
 \ This is called by THROW when n is nonzero
 \ The initial value (DEFAULT-UNWIND) performs the function of ABORT
 \ CATCH saves and restores the current target and substitutes its own version
@@ -44,7 +59,7 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
 
 \ By default, clear the data stack and QUIT without any message
 \ This behavior can be overridden with CATCH
-: ABORT ( i*x -- ) ( R: j*x -- ) -1 THROW ;
+: ABORT ( i*x -- ) ( R: j*x -- ) EXCP-ABORT THROW ;
 
 \ THROWN-STRING holds the address and size of the string passed to FAIL
 \ It may also be used to hold context strings for other system exception codes
@@ -53,7 +68,7 @@ CREATE THROWN-STRING 0 , 0 ,
 \ Display a message and ABORT
 \ This behavior can be overridden with CATCH
 : FAIL ( c-addr u -- <none> | <noreturn> )
-   THROWN-STRING 2! -2 THROW ;
+   THROWN-STRING 2! EXCP-FAIL THROW ;
 
 \ If flag is non-zero, display a message and ABORT
 \ This behavior can be overridden with CATCH
@@ -203,15 +218,15 @@ CREATE THROWN-STRING 0 , 0 ,
 \ The value n can be negative to release the most recently allocated space
 : ALLOT ( n -- )
    DUP 0< IF
-      DUP C0 HERE - < IF -24 THROW THEN
+      DUP C0 HERE - < IF EXCP-BAD-NUMERIC-ARGUMENT THROW THEN
    ELSE
-      DUP HERE INVERT U> IF -8 THROW THEN
+      DUP HERE INVERT U> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
    THEN
    HERE + DUP BRK @ U> IF
       [ DATA-SEGMENT-ALIGNMENT 1- ] LITERAL 2DUP + SWAP INVERT AND
       DUP
       SYS_BRK SYSCALL1
-      OVER <> IF -8 THROW THEN
+      OVER <> IF EXCP-DICTIONARY-OVERFLOW THROW THEN
       BRK !
    THEN
    CP !
@@ -342,20 +357,20 @@ CREATE THROWN-STRING 0 , 0 ,
 \ This function defines what happens when THROW is used outside of any CATCH
 : DEFAULT-UNWIND ( k*x n -- i*x <noreturn> )
    CASE
-      -1 OF ENDOF
+      EXCP-ABORT OF ENDOF
-      -2 OF
+      EXCP-FAIL OF
          THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
       ENDOF
-      -8 OF
+      EXCP-DICTIONARY-OVERFLOW OF
-         "Out of memory\n" TYPE-ERR
+         "Dictionary overflow\n" TYPE-ERR
       ENDOF
-      -13 OF
+      EXCP-UNDEFINED-WORD OF
          "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR
       ENDOF
-      -37 OF
+      EXCP-FILE-IO OF
          "I/O error\n" TYPE-ERR
       ENDOF
-      "Uncaught exception\n" TYPE-ERR
+      "Uncaught exception: " TYPE-ERR
    ENDCASE
    S0 SP! QUIT ;
 
@@ -434,6 +449,10 @@ CREATE CURRENT-SOURCE-ID -1 ,
 
 ' (DOES) (HIDE)
 
+: (MARK) TYPE ": " TYPE .DS EOL ;
+: MARK IMMEDIATE WORD POSTPONE SLITERAL POSTPONE (MARK) ;
+' (MARK) (HIDE)
+
 \ Define a named constant
 \   Execution: ( value "<spaces>name" -- )
 \   name Execution: ( -- value )
@@ -457,6 +476,16 @@ CREATE CURRENT-SOURCE-ID -1 ,
 \   name execution: ( -- value )
 : VALUE CREATE , DOLOAD LATEST >CFA ! ;
 
+\ Define an array of n single-cell elements
+\   name Runtime: ( n -- a-addr ) Return the address of the cell at index n
+: ARRAY ( n "<spaces>name" -- )
+   CREATE CELLS ALLOT DOES> SWAP [ CELL ] LITERAL * + ;
+
+\ Define an array of n double-cell elements
+\   name Runtime: ( n -- a-addr ) Return the address of the double-cell at index n
+: 2ARRAY ( n "<spaces>name" -- )
+   CREATE CELLS 2* ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ;
+
 \ Define a threaded FORTH word
 \ The word is initially hidden so it can refer to a prior word with the same name
 \ The definition is terminated with the ; immediate word, which unhides the name
@@ -544,6 +573,101 @@ CREATE CURRENT-SOURCE-ID -1 ,
       ( S: inner-xt )
    THEN ;
 
+4096 CONSTANT PAGESIZE
+
+0 CONSTANT PROT_NONE
+1 CONSTANT PROT_READ
+2 CONSTANT PROT_WRITE
+4 CONSTANT PROT_EXEC
+
+2 CONSTANT MAP_PRIVATE
+32 CONSTANT MAP_ANONYMOUS
+
+32 CONSTANT BUDDY-MIN-BYTES
+18 CONSTANT BUDDY-ORDERS
+: BUDDY-ORDER-BYTES ( order -- n-bytes ) BUDDY-MIN-BYTES SWAP LSHIFT ;
+BUDDY-ORDERS 1- BUDDY-ORDER-BYTES CONSTANT BUDDY-MAX-BYTES
+
+BUDDY-ORDERS ARRAY BUDDY-HEADS
+
+: INIT-BUDDY-HEADS ( -- )
+   BUDDY-ORDERS 0 DO 0 I BUDDY-HEADS ! LOOP ;
+
+INIT-BUDDY-HEADS
+
+: BUDDY-FREE ( order a-addr -- )
+   OVER BUDDY-ORDERS U>= "order out of bounds" ?FAIL
+   2DUP SWAP BUDDY-ORDER-BYTES 1- AND "address is not naturally aligned" ?FAIL
+   >R DUP BUDDY-HEADS
+   BEGIN
+      ( S: order head-addr ) ( R: a-addr )
+      DUP @
+      DUP 0= IF
+         \ Append to end of list
+         DROP 0 R@ ! R> SWAP !
+         DROP EXIT
+      THEN
+      ( S: order head-addr block-addr ) ( R: freed-addr )
+      2 PICK 1+ BUDDY-ORDERS < AND-THEN
+         DUP 3 PICK BUDDY-ORDER-BYTES XOR R@ = AND-THEN
+            \ Found the buddy on the free list; coalesce
+            @ SWAP !
+            \ Pick the lower (naturally aligned) block address
+            DUP BUDDY-ORDER-BYTES INVERT R> AND >R
+            \ Repeat process with the next-higher order
+            1+ DUP BUDDY-HEADS TRUE
+         THEN
+      THEN 0= IF
+         \ Insert before first item with address >= this addr
+         DUP R@ U>= IF R@ ! R> SWAP ! DROP EXIT THEN
+         \ Otherwise advance to next block
+         NIP
+      THEN
+   AGAIN ;
+
+: BUDDY-ALLOCATE ( order -- a-addr ) RECURSIVE
+   DUP BUDDY-ORDERS U>= "order out of bounds" ?FAIL
+   DUP BUDDY-HEADS @ ?DUP IF DUP @ ROT BUDDY-HEADS ! EXIT THEN
+   DUP 1+ BUDDY-ORDERS >= IF EXCP-HEAP-OVERFLOW THROW THEN
+   DUP 1+ BUDDY-ALLOCATE SWAP 2DUP BUDDY-ORDER-BYTES + BUDDY-FREE ;
+
+: BUDDY-ORDER-FROM-BYTES ( u-bytes -- order )
+   DUP 0= OR-ELSE DUP DUP 1- AND 0<> THEN
+      "buddy allocator block size is not a power of two" ?FAIL
+   DUP BUDDY-MIN-BYTES - [ BUDDY-MAX-BYTES BUDDY-MIN-BYTES - ] LITERAL U>
+      "buddy allocator block size out of bounds" ?FAIL
+   BUDDY-MIN-BYTES / 0 SWAP BEGIN 2/ ?DUP 0<> WHILE SWAP 1+ SWAP REPEAT ;
+
+: BUDDY-COUNT BUDDY-HEADS @ 0 SWAP BEGIN ?DUP WHILE @ SWAP 1+ SWAP REPEAT ;
+
+VARIABLE TOTAL
+: BUDDY-STATS ( -- )
+   0 TOTAL !
+   BUDDY-ORDERS 0 DO
+      I BUDDY-COUNT ?DUP IF
+         DUP I BUDDY-ORDER-BYTES * TOTAL +!
+         . "x" TYPE I BUDDY-ORDER-BYTES . SPACE
+      THEN
+   LOOP "total " TYPE TOTAL @ . EOL ;
+' TOTAL (HIDE)
+
+: NATURALLY-ALIGNED ( u1 -- u2 )
+   1- DUP U2/ OR DUP 2 RSHIFT OR DUP 4 RSHIFT OR DUP 8 RSHIFT OR DUP 16 RSHIFT OR 1+ ;
+
+: ALIGNED-TO ( addr1 u -- addr2 )
+   NATURALLY-ALIGNED TUCK 1- + SWAP NEGATE AND ;
+
+: ALIGN-TO ( u -- )
+   HERE SWAP ALIGNED-TO HERE - ALLOT ;
+
+: ALLOCATE ( size -- a-addr )
+   CELL+ DUP BUDDY-MAX-BYTES CELL- U> "unsupported size" ?FAIL
+   NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN
+   BUDDY-ORDER-FROM-BYTES DUP BUDDY-ALLOCATE SWAP OVER ! CELL+ ;
+
+: FREE ( a-addr -- )
+   CELL- DUP @ SWAP BUDDY-FREE ;
+
 \ Read the next word and return the first character
 : CHAR ( "<spaces>name" -- c )
    WORD DROP C@ ;
@@ -720,7 +844,7 @@ VARIABLE ORDER-FREELIST
 
 \ Same as FIND except that unknown words are reported and result in a call to THROW
 : FIND-OR-THROW ( c-addr u -- xt 1 | xt -1 )
-   FIND ?DUP 0= IF THROWN-STRING 2! -13 THROW THEN ;
+   FIND ?DUP 0= IF THROWN-STRING 2! EXCP-UNDEFINED-WORD THROW THEN ;
 
 \ Read a word from the input (during runtime) and return its execution token
 \ Aborts if the word is not found in the current (runtime) search order list
@@ -790,7 +914,7 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
                DUP ERRNO_EINTR NEGATE <>
             UNTIL
             \ Any other negative (error) return value is fatal
-            DUP 0< IF -37 THROW THEN
+            DUP 0< IF EXCP-FILE-IO THROW THEN
             ( S: length idx u-read )
             \ Add the amount of data read to the length; index is unchanged
             ROT + SWAP
@@ -902,6 +1026,9 @@ HIDE TERMINAL-BUFFER
       THEN
    REPEAT ;
 
+DEFER SHOW-PROMPT
+{ "OK> " TYPE } IS SHOW-PROMPT
+
 \ Redefine QUIT as a non-deferred word; update deferred references to point here
 \ Empty the return stack, make stdin the input source, and enter interpretation state
 :REPLACE QUIT ( -- <noreturn> )
@@ -914,7 +1041,7 @@ HIDE TERMINAL-BUFFER
       THEN
       INTERPRET
       STATE @ 0= IF
-         "OK> " TYPE
+         SHOW-PROMPT
       THEN
    AGAIN ;