align ALLOCATE'd memory to 8 bytes with a magic number in the extra cell
This commit is contained in:
parent
0d107e17d2
commit
24682b970b
138
startup.4th
138
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 ( -- <noreturn> )
|
|||
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 "<spaces>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 "<spaces?>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 "<spaces?>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 ( "<spaces>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 ( "<spaces><type-name>" -- size ) IMMEDIATE
|
||||
' EXECUTE %SIZEOF STATE @ IF POSTPONE LITERAL THEN ;
|
||||
: ALIGNOF ( "<spaces><type-name>" -- 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 ( "<spaces><field-name>" -- 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue