From 24682b970b95074a9760063a73a1c1302de86688 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 25 Oct 2020 01:49:42 -0500 Subject: [PATCH] align ALLOCATE'd memory to 8 bytes with a magic number in the extra cell --- startup.4th | 138 ++++++++++++++++++++++++++++++++---------------- test/resize.4th | 13 +++-- test/resize.exp | 23 ++++---- 3 files changed, 113 insertions(+), 61 deletions(-) diff --git a/startup.4th b/startup.4th index 2900a30..b3bc9ec 100644 --- a/startup.4th +++ b/startup.4th @@ -85,6 +85,7 @@ LATEST ' BOOTSTRAP-GET-ORDER DEFER! -5 CONSTANT EXCP-RETURN-OVERFLOW -6 CONSTANT EXCP-RETURN-UNDERFLOW -8 CONSTANT EXCP-DICTIONARY-OVERFLOW +-9 CONSTANT EXCP-INVALID-ADDRESS -13 CONSTANT EXCP-UNDEFINED-WORD -24 CONSTANT EXCP-BAD-NUMERIC-ARGUMENT -37 CONSTANT EXCP-FILE-IO @@ -1008,6 +1009,9 @@ DEFER QUIT ( -- ) EXCP-DICTIONARY-OVERFLOW OF "Dictionary overflow\n" TYPE-ERR ENDOF + EXCP-INVALID-ADDRESS OF + "Invalid memory address\n" TYPE-ERR + ENDOF EXCP-UNDEFINED-WORD OF "Undefined word: " TYPE-ERR THROWN-STRING 2@ TYPE-ERR "\n" TYPE-ERR ENDOF @@ -1191,10 +1195,31 @@ DEFER REFILL : 2ARRAY ( n "name" -- ) CREATE 2* CELLS ALLOT DOES> SWAP [ 2 CELLS ] LITERAL * + ; -\ Define a threaded word which also displays its name and the data stack when called -: (TRACE) >NAME TYPE SPACE .S ; -: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; -' (TRACE) (HIDE) +\ Structures begin with byte alignment and an offset of zero +1 0 2CONSTANT STRUCT + +\ Basic type descriptors giving alignment and size for each type +1 1 2CONSTANT CHAR% +1 ALIGNED 1 CELLS 2CONSTANT CELL% +1 ALIGNED 2 CELLS 2CONSTANT 2CELL% + +\ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size +\ Each field word has runtime effect ( struct-addr -- field-addr) +\ If field offset is zero then the word is marked as immediate and generates no code +: FIELD ( align1 offset1 field-align field-bytes -- align2 offset2 ) + -ROT NATURALLY-ALIGNED DUP >R ALIGNED-TO + DUP : ?DUP IF POSTPONE LITERAL POSTPONE + ELSE POSTPONE IMMEDIATE THEN POSTPONE ; + + SWAP R> UMAX SWAP ; + +\ Consume the final alignment and offset and define a type descriptor for the struct +: ENDSTRUCT ( align offset "name" -- ) + OVER ALIGNED-TO 2CONSTANT ; + +\ Accessors for type descriptors +: %SIZEOF ( align size -- size ) IMMEDIATE + STATE @ IF POSTPONE NIP ELSE NIP THEN ; +: %ALIGNOF ( align size -- align ) IMMEDIATE + STATE @ IF POSTPONE DROP ELSE DROP THEN ; \ Like : but the definition has no name \ The zero-length name still included in the word list so LATEST can refer to it @@ -1410,35 +1435,63 @@ VARIABLE TOTAL R@ OVER R@ - MUNMAP DUP R> R@ 2* + SWAP R> + TUCK - MUNMAP ; +STRUCT +CELL% FIELD MEMBLOCK>SIZE +CELL% FIELD MEMBLOCK>MAGIC +2CELL% 0 * FIELD MEMBLOCK>DATA +ENDSTRUCT MEMBLOCK% + +\ This is used to identify blocks returned by ALLOCATE +( 0xC0DE3319 ) 3235787545 CONSTANT MEMBLOCK-MAGIC + +0 MEMBLOCK>DATA CONSTANT MEMBLOCK-DATA-OFFSET + +: DATA>MEMBLOCK ( obj-addr -- memblock-addr ) + MEMBLOCK-DATA-OFFSET - ; + >>FORTH : ALLOCATE ( size -- obj-addr ) DUP 0= IF EXIT THEN - CELL+ DUP BUDDY-MAX-BYTES U> IF - PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE TUCK ! CELL+ EXIT + MEMBLOCK-DATA-OFFSET + DUP BUDDY-MAX-BYTES U> IF + PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE + ELSE + 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 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+ ; + TUCK MEMBLOCK>SIZE ! + MEMBLOCK-MAGIC OVER MEMBLOCK>MAGIC ! + MEMBLOCK>DATA ; : FREE ( obj-addr -- ) ?DUP IF - 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 + DATA>MEMBLOCK + DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN + 0 OVER MEMBLOCK>MAGIC ! + DUP MEMBLOCK>SIZE @ + DUP BUDDY-ORDERS U< IF + SWAP BUDDY-FREE + ELSE + BEGIN + 2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN + NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL + AGAIN + THEN THEN ; >>SYSTEM : OBJECT-SIZE ( obj-addr -- size ) - CELL- @ DUP BUDDY-ORDERS U< IF BUDDY-ORDER-BYTES THEN CELL- ; + DUP IF + DATA>MEMBLOCK + DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN + MEMBLOCK>SIZE @ DUP BUDDY-ORDERS U< IF BUDDY-ORDER-BYTES THEN + MEMBLOCK-DATA-OFFSET - + THEN ; >>FORTH @@ -1452,7 +1505,9 @@ VARIABLE TOTAL : RESIZE ( obj-addr1 size -- obj-addr1 | obj-addr2 | 0 ) DUP 0= IF DROP FREE 0 EXIT THEN OVER 0= IF NIP ALLOCATE EXIT THEN - OVER OBJECT-SIZE CELL+ OVER CELL+ BUDDY-MIN-BYTES UMAX 2DUP U>= IF + OVER OBJECT-SIZE MEMBLOCK-DATA-OFFSET + + OVER MEMBLOCK-DATA-OFFSET + BUDDY-MIN-BYTES UMAX + 2DUP U>= IF \ Allocated space is larger than requested size, shrink if <= 50% used ( S: obj-addr1 size obj-size req-size ) SWAP 2/ U> IF DROP EXIT THEN @@ -1495,30 +1550,6 @@ VARIABLE TOTAL DODOES OVER ! CELL+ [ ' (CLOSURE) >DFA @ ] LITERAL OVER ! CELL+ 0 OVER ! CELL+ 0 OVER ! CELL+ 2DUP ! CELL+ N! R> ; -\ Basic type descriptors giving alignment and size for each type -1 1 2CONSTANT CHAR% -1 ALIGNED 1 CELLS 2CONSTANT CELL% -1 ALIGNED 2 CELLS 2CONSTANT 2CELL% - -\ Structures begin with byte alignment and an offset of zero -1 0 2CONSTANT STRUCT - -\ Within STRUCT … ENDSTRUCT, define a field with the given alignment and size -\ Each field word has runtime effect ( struct-addr -- field-addr) -\ If field offset is zero then the word is marked as immediate and generates no code -: FIELD ( align1 offset1 field-align field-bytes -- align2 offset2 ) - -ROT NATURALLY-ALIGNED DUP >R ALIGNED-TO - DUP : ?DUP IF POSTPONE LITERAL POSTPONE + ELSE POSTPONE IMMEDIATE THEN POSTPONE ; - + SWAP R> UMAX SWAP ; - -\ Consume the final alignment and offset and define a type descriptor for the struct -: ENDSTRUCT ( align offset "name" -- ) - OVER ALIGNED-TO 2CONSTANT ; - -\ Accessors for type descriptors -: %SIZEOF ( align size -- size ) NIP ; -: %ALIGNOF ( align size -- align ) DROP ; - \ Reserve data or heap space for a data structure given alignment and size \ It is assumed that ALLOCATE (but not ALLOT) returns an address suitably \ aligned for any primitive data type; %ALLOCATE is not suitable for data @@ -1709,6 +1740,18 @@ BOOTSTRAP-GET-ORDER SET-ORDER : :REPLACE ( "ccc" -- ) : LATEST DUP >NAME FIND-OR-THROW DROP DUP (HIDE) DEFER! ; +\ Produce the size or alignment of the subsequent type descriptor as a literal +\ The type-name should be a word like CELL% returning an alignment and a size +: SIZEOF ( "" -- size ) IMMEDIATE + ' EXECUTE %SIZEOF STATE @ IF POSTPONE LITERAL THEN ; +: ALIGNOF ( "" -- size ) IMMEDIATE + ' EXECUTE %ALIGNOF STATE @ IF POSTPONE LITERAL THEN ; + +\ Product the offset of the subsequent field name as a literal +\ The field-name should be a word which adds a field offset to a given address +: OFFSETOF ( "" -- offset ) IMMEDIATE + 0 ' EXECUTE STATE @ IF POSTPONE LITERAL THEN ; + >>SYSTEM \ The size of this buffer will determine the maximum line length @@ -1925,6 +1968,11 @@ HIDE BOOTSTRAP-WORDLIST \ From this point on we only execute threaded FORTH words defined in this file \ ***************************************************************************** +\ Define a threaded word which also displays its name and the data stack when called +: (TRACE) >NAME TYPE SPACE .S ; +: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ; +' (TRACE) (HIDE) + \ Return TRUE if the given address is the execution token of a word in \ the current search order or compilation word list, or FALSE otherwise \ The word's name may be hidden or shadowed by another definition diff --git a/test/resize.4th b/test/resize.4th index ddc057f..2db2610 100644 --- a/test/resize.4th +++ b/test/resize.4th @@ -2,14 +2,17 @@ TYPE ":\n Value: " TYPE DUP @ . "\n Object size: " TYPE DUP OBJECT-SIZE U. EOL EOL ; +SYSTEM-WORDLIST PUSH-ORDER + : TEST - 28 ALLOCATE 1234 OVER ! "Allocated 28 bytes" STATUS + 24 ALLOCATE 1234 OVER ! "Allocated 24 bytes" STATUS 33 RESIZE "Resized to 33 bytes" STATUS - 28 RESIZE "Resized to 28 bytes" STATUS - 256 KB CELL- RESIZE "Resized to 256 KiB - 1 cell" STATUS + 24 RESIZE "Resized to 24 bytes" STATUS + 256 KB MEMBLOCK-DATA-OFFSET - RESIZE "Resized to 256 KiB - header" STATUS 32 RESIZE "Resized to 32 bytes" STATUS - 28 RESIZE "Resized to 28 bytes" STATUS + 24 RESIZE "Resized to 24 bytes" STATUS 4 RESIZE "Resized to 4 bytes" STATUS - FREE ; + DUP FREE + ['] FREE CATCH "CATCH after double-free: " TYPE . EOL ; TEST diff --git a/test/resize.exp b/test/resize.exp index 9001377..061946d 100644 --- a/test/resize.exp +++ b/test/resize.exp @@ -1,29 +1,30 @@ -Allocated 28 bytes: +Allocated 24 bytes: Value: 1234 - Object size: 28 + Object size: 24 Resized to 33 bytes: Value: 1234 - Object size: 60 + Object size: 56 -Resized to 28 bytes: +Resized to 24 bytes: Value: 1234 - Object size: 28 + Object size: 24 -Resized to 256 KiB - 1 cell: +Resized to 256 KiB - header: Value: 1234 - Object size: 262140 + Object size: 262136 Resized to 32 bytes: Value: 1234 - Object size: 60 + Object size: 56 -Resized to 28 bytes: +Resized to 24 bytes: Value: 1234 - Object size: 28 + Object size: 24 Resized to 4 bytes: Value: 1234 - Object size: 28 + Object size: 24 +CATCH after double-free: -9 exit-code: 0