align ALLOCATE'd memory to 8 bytes with a magic number in the extra cell

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
+\ Structures begin with byte alignment and an offset of zero
-: (TRACE) >NAME TYPE SPACE .S ;
+1 0 2CONSTANT STRUCT
-: :TRACE : LATEST POSTPONE LITERAL POSTPONE (TRACE) ;
+
-' (TRACE) (HIDE)
+\ 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
+   MEMBLOCK-DATA-OFFSET + DUP BUDDY-MAX-BYTES U> IF
-      PAGESIZE ALIGNED-TO DUP MMAP-ALLOCATE TUCK ! CELL+ EXIT
+      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
+   TUCK MEMBLOCK>SIZE !
-   BUDDY-ORDER-FROM-BYTES DUP ['] BUDDY-ALLOCATE CATCH ?DUP IF
+   MEMBLOCK-MAGIC OVER MEMBLOCK>MAGIC !
-      DUP EXCP-HEAP-OVERFLOW <> IF RETHROW THEN DROP
+   MEMBLOCK>DATA ;
-      BUDDY-ORDERS 1- BUDDY-MAX-BYTES MMAP-ALLOCATE-ALIGNED BUDDY-FREE
-      BUDDY-ALLOCATE
-   THEN
-   SWAP OVER ! CELL+ ;
 
 : FREE ( obj-addr -- )
    ?DUP IF
-      CELL- DUP @
+      DATA>MEMBLOCK
-      DUP BUDDY-ORDERS U< IF SWAP BUDDY-FREE EXIT THEN
+      DUP MEMBLOCK>MAGIC @ MEMBLOCK-MAGIC <> IF EXCP-INVALID-ADDRESS THROW THEN
-      BEGIN
+      0 OVER MEMBLOCK>MAGIC !
-         2DUP SYS_MUNMAP SYSCALL2 ?DUP 0= IF 2DROP EXIT THEN
+      DUP MEMBLOCK>SIZE @
-         NEGATE ERRNO_EINTR <> "munmap failed" ?FAIL
+      DUP BUDDY-ORDERS U< IF
-      AGAIN
+         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

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
+   24 RESIZE "Resized to 24 bytes" STATUS
-   256 KB CELL- RESIZE "Resized to 256 KiB - 1 cell" 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

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