implement ALLOCATE and FREE using buddy allocator
This commit is contained in:
parent
c0434e415a
commit
b22e3e9c93
157
startup.4th
157
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
|
||||
-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 "<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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue