From 7b44312892cdeece1b95f6666820a62da1a621d7 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Thu, 22 Oct 2020 23:34:05 -0500 Subject: [PATCH] add allocation of blocks for small objects with mmap --- startup.4th | 384 ++++++++++++++++++++++++---------------------- test/allocate.4th | 33 ++++ test/allocate.exp | 12 ++ 3 files changed, 246 insertions(+), 183 deletions(-) create mode 100644 test/allocate.4th create mode 100644 test/allocate.exp diff --git a/startup.4th b/startup.4th index 262284b..8c51201 100644 --- a/startup.4th +++ b/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 ) \ -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 ) - THROWN-STRING 2! +\ +\ For use after CATCH; like THROW but doesn't change the string +: RETHROW ( k*x n -- k*x | i*x n ) ?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 ) +\ THROW while storing a string for context +: THROW-STRING ( k*x n c-addr u -- k*x | i*x n ) + THROWN-STRING 2! RETHROW ; +\ Basic THROW without any string (store an empty string) +: THROW ( k*x n -- k*x | i*x n ) 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 ( "name" -- c ) WORD DROP C@ ; @@ -1077,6 +974,180 @@ VARIABLE ORDER-FREELIST \ Hide the named word: HIDE : HIDE ( "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 ) + 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 ( "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 ) - 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 ( "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 ( "name" -- ) ' (SEE) ; + HIDE UNTHREAD : WORDS ( -- ) diff --git a/test/allocate.4th b/test/allocate.4th new file mode 100644 index 0000000..d9c214e --- /dev/null +++ b/test/allocate.4th @@ -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 diff --git a/test/allocate.exp b/test/allocate.exp new file mode 100644 index 0000000..412c87d --- /dev/null +++ b/test/allocate.exp @@ -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