add allocation of blocks for small objects with mmap
This commit is contained in:
parent
64a1ee9810
commit
7b44312892
384
startup.4th
384
startup.4th
|
|
@ -9,6 +9,13 @@
|
|||
: ALIGNED ( addr -- a-addr )
|
||||
[ CELL 1- ] LITERAL + [ CELL NEGATE ] LITERAL AND ;
|
||||
|
||||
\ Returns the least power of two greater than or equal to u1
|
||||
: 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 ;
|
||||
|
||||
\ Field accessors for execution tokens
|
||||
: >CFA ( xt -- a-addr ) ;
|
||||
: >DFA ( xt -- a-addr ) CELL+ ;
|
||||
|
|
@ -58,12 +65,15 @@ DEFER THROW-UNWIND ( k*x n -- i*x <noreturn> )
|
|||
\ -1 (ABORT) no message
|
||||
\ -2 (FAIL) the string passed to THROW-STRING
|
||||
\ otherwise message is implementation-dependent
|
||||
: THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
||||
THROWN-STRING 2!
|
||||
\
|
||||
\ For use after CATCH; like THROW but doesn't change the string
|
||||
: RETHROW ( k*x n -- k*x | i*x n <noreturn> )
|
||||
?DUP IF THROW-UNWIND THEN ;
|
||||
|
||||
\ Same but without the string (default to zero-length)
|
||||
: THROW ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
||||
\ THROW while storing a string for context
|
||||
: THROW-STRING ( k*x n c-addr u -- k*x | i*x n <noreturn> )
|
||||
THROWN-STRING 2! RETHROW ;
|
||||
\ Basic THROW without any string (store an empty string)
|
||||
: THROW ( k*x n -- k*x | i*x n <noreturn> )
|
||||
0 0 THROW-STRING ;
|
||||
|
||||
\ By default, clear the data stack and QUIT without any message
|
||||
|
|
@ -295,6 +305,9 @@ CREATE DISPLAY-ITEM-LIMIT 6 ,
|
|||
\ Allocate bytes from the data area (less than one cell) to cell-align the address
|
||||
: ALIGN HERE ALIGNED HERE - BEGIN ?DUP WHILE 0 C, 1- REPEAT ;
|
||||
|
||||
: ALIGN-TO ( u -- )
|
||||
HERE SWAP ALIGNED-TO HERE - ALLOT ;
|
||||
|
||||
\ Append the effect of the token on top of the stack to the current definition.
|
||||
\ Here it's equivalent to , since words are just arrays of execution tokens.
|
||||
\ Once COMPILE, has been defined we can use POSTPONE for non-immediate words.
|
||||
|
|
@ -486,16 +499,14 @@ CREATE LEAVE-ORIG 0 ,
|
|||
' DEFAULT-UNWIND (HIDE)
|
||||
|
||||
\ Copy the bootstrap SOURCE values into variables to allow changing the input buffer
|
||||
SOURCE
|
||||
CREATE INPUT-BUFFER-SIZE ,
|
||||
CREATE INPUT-BUFFER ,
|
||||
CREATE INPUT-BUFFER SOURCE 2,
|
||||
|
||||
\ The SOURCE-ID is -1 for a string (EVALUATE) or 0 for user input
|
||||
\ Any other values are implementation-defined, for example FD numbers for file input
|
||||
CREATE CURRENT-SOURCE-ID -1 ,
|
||||
|
||||
\ Report the current input buffer region and SOURCE-ID
|
||||
: SOURCE ( -- c-addr u ) INPUT-BUFFER @ INPUT-BUFFER-SIZE @ ;
|
||||
: SOURCE ( -- c-addr u ) INPUT-BUFFER 2@ ;
|
||||
: SOURCE-ID ( -- 0 | -1 | +n ) CURRENT-SOURCE-ID @ ;
|
||||
|
||||
\ Save and restore the input source parameters (e.g. file position)
|
||||
|
|
@ -563,8 +574,7 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
|
|||
TUCK - TIB-LEFTOVER-SIZE !
|
||||
( S: idx )
|
||||
\ The new input buffer is the first idx characters of the terminal buffer
|
||||
TERMINAL-BUFFER INPUT-BUFFER !
|
||||
DUP INPUT-BUFFER-SIZE !
|
||||
TERMINAL-BUFFER OVER INPUT-BUFFER 2!
|
||||
DUP IF 0 >IN ! THEN
|
||||
0<> ;
|
||||
|
||||
|
|
@ -780,119 +790,6 @@ CREATE TIB-LEFTOVER-SIZE 0 ,
|
|||
\ [THEN] is just a placeholder to terminate [IF] or [ELSE]; no compilation effect
|
||||
: [THEN] IMMEDIATE ;
|
||||
|
||||
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@ =
|
||||
THEN 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 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 ;
|
||||
|
||||
0 CONSTANT NULL
|
||||
: KB 10 LSHIFT ;
|
||||
: MB 20 LSHIFT ;
|
||||
|
||||
: ALLOCATE ( size -- a-addr )
|
||||
CELL+ DUP BUDDY-MAX-BYTES U> IF
|
||||
BEGIN
|
||||
NULL OVER PROT_READ PROT_WRITE OR
|
||||
MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6
|
||||
DUP -4095 U>=
|
||||
WHILE
|
||||
NEGATE ERRNO_EINTR <> IF EXCP-HEAP-OVERFLOW THROW THEN
|
||||
REPEAT
|
||||
TUCK ! CELL+ EXIT
|
||||
THEN
|
||||
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 @
|
||||
DUP BUDDY-ORDERS U< IF SWAP BUDDY-FREE EXIT THEN
|
||||
BEGIN
|
||||
2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN
|
||||
NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL
|
||||
AGAIN ;
|
||||
|
||||
\ Read the next word and return the first character
|
||||
: CHAR ( "<spaces>name" -- c )
|
||||
WORD DROP C@ ;
|
||||
|
|
@ -1077,6 +974,180 @@ VARIABLE ORDER-FREELIST
|
|||
\ Hide the named word: HIDE <name>
|
||||
: HIDE ( "<spaces>ccc" -- ) ' (HIDE) ;
|
||||
|
||||
0 VALUE EXCEPTION-STACK
|
||||
|
||||
\ Called when THROW is called inside of CATCH
|
||||
\ Restore the input source specification, stack point, and return stack pointer
|
||||
\ Push the error code from THROW onto the data stack
|
||||
\ Return to the code that called CATCH
|
||||
: CATCH-UNWIND ( k*x n -- i*x <noreturn> )
|
||||
EXCEPTION-STACK RSP!
|
||||
R> TO EXCEPTION-STACK
|
||||
R> IS THROW-UNWIND
|
||||
R> CURRENT-SOURCE-ID !
|
||||
2R> INPUT-BUFFER 2!
|
||||
NR> RESTORE-INPUT DROP
|
||||
R> SWAP >R SP! R> ;
|
||||
|
||||
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
|
||||
\ On success has the effect of xt and also leaves the value 0 on top of the stack
|
||||
\ On failure the stacks and input source are reverted and the THROW code is pushed
|
||||
: CATCH ( i*x xt -- j*x 0 | i*x n )
|
||||
\ Get original RSP to be saved on return stack later, after the exception frame
|
||||
RSP@
|
||||
\ Don't include the xt or RSP when saving the stack pointer
|
||||
2>R SP@ 2R> ROT >R
|
||||
\ Save the input source specification
|
||||
SAVE-INPUT N>R
|
||||
SOURCE 2>R
|
||||
SOURCE-ID >R
|
||||
\ We'll need these to revert the effect of CATCH, with or without THROW
|
||||
['] THROW-UNWIND DEFER@ >R
|
||||
EXCEPTION-STACK >R
|
||||
\ Push the new exception stack frame
|
||||
RSP@ TO EXCEPTION-STACK
|
||||
\ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND
|
||||
['] CATCH-UNWIND IS THROW-UNWIND
|
||||
\ Save the original return stack so we can quickly free the exception frame
|
||||
( RSP@ from start of CATCH ) >R
|
||||
\ Run the function; if THROW is called then EXECUTE won't return
|
||||
\ If it does return then push 0 to indicate success
|
||||
EXECUTE 0
|
||||
R> R> R>
|
||||
\ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame
|
||||
['] THROW-UNWIND DEFER!
|
||||
TO EXCEPTION-STACK
|
||||
\ We don't need the rest so just reset the RSP to where it was on entering CATCH
|
||||
RSP! ;
|
||||
|
||||
HIDE EXCEPTION-STACK
|
||||
HIDE CATCH-UNWIND
|
||||
HIDE THROW-UNWIND
|
||||
|
||||
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@ =
|
||||
THEN 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 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 ;
|
||||
HIDE TOTAL
|
||||
|
||||
0 CONSTANT NULL
|
||||
|
||||
: KB 10 LSHIFT ;
|
||||
: MB 20 LSHIFT ;
|
||||
|
||||
4 KB 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
|
||||
|
||||
: MMAP-ALLOCATE ( size -- a-addr )
|
||||
BEGIN
|
||||
NULL OVER PROT_READ PROT_WRITE OR
|
||||
MAP_PRIVATE MAP_ANONYMOUS OR -1 0 SYS_MMAP2 SYSCALL6
|
||||
DUP -4095 U>=
|
||||
WHILE
|
||||
NEGATE ERRNO_EINTR <> IF EXCP-HEAP-OVERFLOW THROW THEN
|
||||
REPEAT NIP ;
|
||||
|
||||
: MUNMAP ( addr length -- )
|
||||
DUP IF BEGIN 2DUP SYS_MUNMAP SYSCALL2 NEGATE ERRNO_EINTR <> UNTIL THEN 2DROP ;
|
||||
|
||||
: MMAP-ALLOCATE-ALIGNED ( size -- a-addr )
|
||||
NATURALLY-ALIGNED
|
||||
DUP 2* MMAP-ALLOCATE SWAP
|
||||
( S: addr size )
|
||||
2DUP ALIGNED-TO
|
||||
( S: addr size a-addr )
|
||||
-ROT >R >R
|
||||
( S: a-addr R: size addr )
|
||||
R@ OVER R@ - MUNMAP
|
||||
DUP R> R@ 2* + SWAP R> + TUCK - MUNMAP ;
|
||||
|
||||
: ALLOCATE ( size -- a-addr )
|
||||
CELL+ DUP BUDDY-MAX-BYTES U> IF DUP MMAP-ALLOCATE TUCK ! CELL+ EXIT THEN
|
||||
NATURALLY-ALIGNED DUP BUDDY-MIN-BYTES U< IF DROP BUDDY-MIN-BYTES THEN
|
||||
BUDDY-ORDER-FROM-BYTES DUP ['] BUDDY-ALLOCATE CATCH ?DUP IF
|
||||
DUP EXCP-HEAP-OVERFLOW <> IF RETHROW THEN DROP
|
||||
BUDDY-ORDERS 1- BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-FREE
|
||||
BUDDY-ALLOCATE
|
||||
THEN
|
||||
SWAP OVER ! CELL+ ;
|
||||
|
||||
: FREE ( a-addr -- )
|
||||
CELL- DUP @
|
||||
DUP BUDDY-ORDERS U< IF SWAP BUDDY-FREE EXIT THEN
|
||||
BEGIN
|
||||
2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN
|
||||
NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL
|
||||
AGAIN ;
|
||||
|
||||
\ Begin a new colon definition; hide & redirect the previous word
|
||||
\ with the same name to the new definition
|
||||
: :REPLACE ( "<spaces>ccc" -- )
|
||||
|
|
@ -1195,71 +1266,16 @@ STDIN TTY? CONSTANT INTERACTIVE?
|
|||
SAVE-INPUT N>R
|
||||
SOURCE 2>R
|
||||
SOURCE-ID >R
|
||||
INPUT-BUFFER-SIZE !
|
||||
INPUT-BUFFER !
|
||||
INPUT-BUFFER 2!
|
||||
0 >IN !
|
||||
-1 CURRENT-SOURCE-ID !
|
||||
INTERPRET
|
||||
R> CURRENT-SOURCE-ID !
|
||||
2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER !
|
||||
2R> INPUT-BUFFER 2!
|
||||
NR> RESTORE-INPUT DROP ;
|
||||
|
||||
0 VALUE EXCEPTION-STACK
|
||||
|
||||
\ Called when THROW is called inside of CATCH
|
||||
\ Restore the input source specification, stack point, and return stack pointer
|
||||
\ Push the error code from THROW onto the data stack
|
||||
\ Return to the code that called CATCH
|
||||
: CATCH-UNWIND ( k*x n -- i*x <noreturn> )
|
||||
EXCEPTION-STACK RSP!
|
||||
R> TO EXCEPTION-STACK
|
||||
R> ['] THROW-UNWIND DEFER!
|
||||
R> CURRENT-SOURCE-ID !
|
||||
2R> INPUT-BUFFER-SIZE ! INPUT-BUFFER !
|
||||
NR> RESTORE-INPUT DROP
|
||||
R> SWAP >R SP! R> ;
|
||||
|
||||
\ Run xt while trapping calls to THROW, ABORT, FAIL, etc.
|
||||
\ On success has the effect of xt and also leaves the value 0 on top of the stack
|
||||
\ On failure the stacks and input source are reverted and the THROW code is pushed
|
||||
: CATCH ( i*x xt -- j*x 0 | i*x n )
|
||||
\ Get original RSP to be saved on return stack later, after the exception frame
|
||||
RSP@
|
||||
\ Don't include the xt or RSP when saving the stack pointer
|
||||
2>R SP@ 2R> ROT >R
|
||||
\ Save the input source specification
|
||||
SAVE-INPUT N>R
|
||||
SOURCE 2>R
|
||||
SOURCE-ID >R
|
||||
\ We'll need these to revert the effect of CATCH, with or without THROW
|
||||
['] THROW-UNWIND DEFER@ >R
|
||||
EXCEPTION-STACK >R
|
||||
\ Push the new exception stack frame
|
||||
RSP@ TO EXCEPTION-STACK
|
||||
\ Arrange for THROW to call CATCH-UNWIND instead of DEFAULT-UNWIND
|
||||
['] CATCH-UNWIND IS THROW-UNWIND
|
||||
\ Save the original return stack so we can quickly free the exception frame
|
||||
( RSP@ from start of CATCH ) >R
|
||||
\ Run the function; if THROW is called then EXECUTE won't return
|
||||
\ If it does return then push 0 to indicate success
|
||||
EXECUTE 0
|
||||
R> R> R>
|
||||
\ Revert THROW-UNWIND and EXCEPTION-STACK using data from exception frame
|
||||
['] THROW-UNWIND DEFER!
|
||||
TO EXCEPTION-STACK
|
||||
\ We don't need the rest so just reset the RSP to where it was on entering CATCH
|
||||
RSP! ;
|
||||
|
||||
HIDE EXCEPTION-STACK
|
||||
HIDE CATCH-UNWIND
|
||||
HIDE THROW-UNWIND
|
||||
|
||||
HIDE CURRENT-SOURCE-ID
|
||||
HIDE INPUT-BUFFER
|
||||
HIDE INPUT-BUFFER-SIZE
|
||||
|
||||
HIDE (HIDE)
|
||||
HIDE (UNHIDE)
|
||||
|
||||
HIDE ESCAPED-CHAR
|
||||
HIDE READSTRING
|
||||
|
|
@ -1403,8 +1419,8 @@ DEFINITIONS
|
|||
|
||||
HIDE NONAME-LITERAL?
|
||||
|
||||
: SEE ( "<spaces>name" -- )
|
||||
' DUP >CFA @ CASE
|
||||
: (SEE) ( xt -- )
|
||||
DUP >CFA @ CASE
|
||||
DOCOL OF
|
||||
": " TYPE DUP >NAME TYPE " " TYPE
|
||||
DUP IMMEDIATE? IF "IMMEDIATE " TYPE THEN
|
||||
|
|
@ -1428,6 +1444,8 @@ HIDE NONAME-LITERAL?
|
|||
SWAP "CREATE " TYPE >NAME TYPE " … ;CODE … END-CODE\n" TYPE
|
||||
ENDCASE ;
|
||||
|
||||
: SEE ( "<spaces>name" -- ) ' (SEE) ;
|
||||
|
||||
HIDE UNTHREAD
|
||||
|
||||
: WORDS ( -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,33 @@
|
|||
0 VALUE LARGE-OBJECT
|
||||
0 VALUE LIST-HEAD
|
||||
|
||||
: HEADING "* " TYPE TYPE EOL ;
|
||||
|
||||
: TEST
|
||||
"Allocate large object (8 MiB)" HEADING
|
||||
8 MB ALLOCATE TO LARGE-OBJECT
|
||||
LARGE-OBJECT 8 MB BL FILL
|
||||
BUDDY-STATS EOL
|
||||
|
||||
"Free large object" HEADING
|
||||
LARGE-OBJECT FREE
|
||||
NULL TO LARGE-OBJECT
|
||||
BUDDY-STATS EOL
|
||||
|
||||
"Allocate 1000 small objects (200 B)" HEADING
|
||||
1000 0 DO
|
||||
200 ALLOCATE
|
||||
LIST-HEAD OVER !
|
||||
TO LIST-HEAD
|
||||
LOOP
|
||||
BUDDY-STATS EOL
|
||||
|
||||
"Free 1000 small objects" HEADING
|
||||
LIST-HEAD BEGIN
|
||||
?DUP
|
||||
WHILE
|
||||
DUP @ SWAP FREE
|
||||
REPEAT
|
||||
BUDDY-STATS ;
|
||||
|
||||
TEST
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
* Allocate large object (8 MiB)
|
||||
total 0
|
||||
|
||||
* Free large object
|
||||
total 0
|
||||
|
||||
* Allocate 1000 small objects (200 B)
|
||||
1x2048 1x4096 1x262144 1x524288 1x1048576 1x2097152 total 3938304
|
||||
|
||||
* Free 1000 small objects
|
||||
1x4194304 total 4194304
|
||||
exit-code: 0
|
||||
Loading…
Reference in New Issue