From b22e3e9c930de16c69cac6d2c5f4cbc810bb7e42 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 18 Oct 2020 20:53:03 -0500 Subject: [PATCH] implement ALLOCATE and FREE using buddy allocator --- startup.4th | 157 +++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 142 insertions(+), 15 deletions(-) diff --git a/startup.4th b/startup.4th index 32cebb1..665f801 100644 --- a/startup.4th +++ b/startup.4th @@ -28,6 +28,21 @@ DEFER QUIT ( -- ) ' 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 ) \ 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 -- | ) - 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 ) CASE - -1 OF ENDOF - -2 OF + EXCP-ABORT OF ENDOF + EXCP-FAIL OF THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR ENDOF - -8 OF - "Out of memory\n" TYPE-ERR + EXCP-DICTIONARY-OVERFLOW OF + "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 "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 "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 "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 ( "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 ( -- ) @@ -914,7 +1041,7 @@ HIDE TERMINAL-BUFFER THEN INTERPRET STATE @ 0= IF - "OK> " TYPE + SHOW-PROMPT THEN AGAIN ;