Implement use-after-rewind detection in arenas

not exactly use-after-free because it does not free the memory,
but it deals with a similar issue. By changing REWIND-ARENA to HIDE-ARENA,
and then working with a different arena, you can trap erroneous references
to the hidden arena without the further damage that would come from
seeing partially overwritten memory if you reused that same arena.

src/code/arena.lisp

@@ -8,12 +8,15 @@
           arena-userdata
           new-arena
           destroy-arena
+          hide-arena
+          unhide-arena
           switch-to-arena
           rewind-arena
           unuse-arena
           thread-current-arena
           in-same-arena
           dump-arena-objects
+          arena-contents
           c-find-heap->arena
           points-to-arena
           show-heap->arena))
@@ -81,6 +84,7 @@ one or more times, not to exceed MAX-EXTENSIONS times"
           (arena-growth-amount arena) growth-amount
           (arena-max-extensions arena) max-extensions
           (arena-index arena) index
+          (arena-hidden arena) nil
           (arena-token arena) 1
           (arena-userdata arena) nil)
     arena))
@@ -178,6 +182,24 @@ one or more times, not to exceed MAX-EXTENSIONS times"
           (when (< (sap-int memblk) addr (sap-int (arena-memblk-freeptr memblk)))
             (return-from find-containing-arena arena)))))))
 
+(defun arena-mprotect (arena protect)
+  (alien-funcall (extern-alien "arena_mprotect" (function void unsigned int))
+                 (get-lisp-obj-address arena)
+                 (if protect 1 0))
+  arena)
+
+(defun hide-arena (arena)
+  (aver (not (arena-hidden arena)))
+  ;; Inform GC as of now not to look in the arena
+  (setf (arena-hidden arena) t)
+  (arena-mprotect arena t))
+(defun unhide-arena (arena)
+  (aver (arena-hidden arena))
+  (arena-mprotect arena nil)
+  ;; Inform GC as of now that it can look in the arena
+  (setf (arena-hidden arena) nil)
+  arena)
+
 (defun maybe-show-arena-switch (direction reason)
   (declare (ignore direction reason)))
 #+system-tlabs
@@ -212,7 +234,7 @@ one or more times, not to exceed MAX-EXTENSIONS times"
     ;; entire mechanism is still slightly unsafe because the finder returns raw addresses.
     (flet ((find-tls-ref (addr)
              (binding* ((node (sb-thread::avl-find<= addr sb-thread::*all-threads*) :exit-if-null)
-                        (thread-sap (sb-sys:int-sap
+                        (thread-sap (int-sap
                                      (sb-thread::thread-primitive-thread
                                       (sb-thread::avlnode-data node)))))
                (when (and (<= (sap-int thread-sap) addr)
@@ -223,7 +245,7 @@ one or more times, not to exceed MAX-EXTENSIONS times"
                          :tls symbol)))))
            (find-binding (addr)
              (binding* ((node (sb-thread::avl-find>= addr sb-thread::*all-threads*) :exit-if-null)
-                        (thread-sap (sb-sys:int-sap
+                        (thread-sap (int-sap
                                      (sb-thread::thread-primitive-thread
                                       (sb-thread::avlnode-data node))))
                         (bindstack-base

src/code/room.lisp

@@ -1436,9 +1436,11 @@ We could try a few things to mitigate this:
                      (type-of x)
                      (type-of pointee)))))))
 
+(macrolet ((aligned-base (blk)
+             `(align-up (sap-int (sap+ ,blk (* 4 n-word-bytes))) 4096)))
 (defun dump-arena-objects (arena &aux (tot-size 0))
   (do-arena-blocks (memblk arena)
-    (let ((from (sap-int memblk) )
+    (let ((from (aligned-base memblk))
           (to (sap-int (arena-memblk-freeptr memblk))))
       (format t "~&Memory block ~X..~X~%" from to)
       (map-objects-in-range
@@ -1446,10 +1448,33 @@ We could try a few things to mitigate this:
          (declare (ignore type))
          (incf tot-size size)
          (format t "~x ~s~%" (get-lisp-obj-address obj) (type-of obj)))
-       (make-lisp-obj from)
-       (make-lisp-obj to))))
+       (%make-lisp-obj from)
+       (%make-lisp-obj to))))
   tot-size)
-)
+(defun arena-contents (arena)
+  (let ((count 0))
+    (do-arena-blocks (memblk arena)
+      (let ((base (aligned-base memblk))
+            (limit (sap-int (arena-memblk-freeptr memblk))))
+        (map-objects-in-range
+         (lambda (obj widetag size)
+           (declare (ignore obj widetag size))
+           (incf count))
+         (%make-lisp-obj base)
+         (%make-lisp-obj limit))))
+    (let ((result (make-array count))
+          (index 0))
+      (do-arena-blocks (memblk arena)
+        (let ((base (aligned-base memblk))
+              (limit (sap-int (arena-memblk-freeptr memblk))))
+          (map-objects-in-range
+           (lambda (obj widetag size)
+             (declare (ignore widetag size))
+             (setf (aref result index) obj)
+             (incf count))
+           (%make-lisp-obj base)
+           (%make-lisp-obj limit))))
+      result)))))
 
 (in-package "SB-C")
 ;;; As soon as practical in warm build it makes sense to add

src/compiler/generic/late-objdef.lisp

@@ -252,6 +252,7 @@ static inline lispobj compute_lispobj(lispobj* base_addr) {
   ;; Address of the one mandatory 'struct arena_memblk' for this arena
   (first-block 0 :type word)
   ;; Arena allocation parameters
+  (original-size 0 :type word)
   (growth-amount 0 :type word) ; additive
   (max-extensions 0 :type word)
   ;; Sum of sizes of currently allocated blocks
@@ -264,6 +265,8 @@ static inline lispobj compute_lispobj(lispobj* base_addr) {
   (extension-count 0 :type word)
   ;; Small integer identifier starting from 0
   (index 0 :type fixnum)
+  ;; T if all memory has been protected with PROT_NONE (for debugging)
+  hidden
   ;; a counter that increments on each rewind, and which can be used by a threads
   ;; in a pool to detect that their cached TLAB pointers are invalid
   (token 0 :type word)

src/runtime/arena.c

@@ -12,6 +12,7 @@
 #include "gencgc-private.h"
 #include "lispregs.h"
 #include "genesis/arena.h"
+#include "genesis/gc-tables.h"
 #include "thread.h"
 
 extern void acquire_gc_page_table_lock(), release_gc_page_table_lock();
@@ -46,6 +47,8 @@ void ARENA_DISPOSE_MEMORY(void* addr, size_t size)
 }
 #endif
 
+#define CHUNK_ALIGN 4096
+
 lispobj sbcl_new_arena(size_t size)
 {
     // First 3 objects in the arena:
@@ -54,6 +57,7 @@ lispobj sbcl_new_arena(size_t size)
     //   Memblk
     struct arena* arena = ARENA_GET_OS_MEMORY(size);
     memset(arena, 0, sizeof *arena);
+    arena->header = (sizeof (struct arena) / N_WORD_BYTES) << INSTANCE_LENGTH_SHIFT;
     struct arena_memblk* block =
       (void*)((char*)arena + ALIGN_UP(sizeof (struct arena), 2*N_WORD_BYTES));
     // arenas require threads, but the header for the mutex definition
@@ -68,10 +72,20 @@ lispobj sbcl_new_arena(size_t size)
 #endif
     block = (void*)((char*)block + ALIGN_UP(sizeof *mutex, 2*N_WORD_BYTES));
 #endif
-    block->freeptr = (char*)block + sizeof *block;
-    block->limit = (char*)arena + size;
+    char* mem_base = (char*)block + sizeof *block;
+    // Prevent user allocations from starting at an address that is not
+    // a multiple of 4k. In this manner it is possible to mprotect
+    // all user allocations instead of having to skip the first batch
+    // so that the arena struct always remains accessible.
+    char* aligned_mem_base = PTR_ALIGN_UP(mem_base, CHUNK_ALIGN);
+    memset(mem_base, 0xCC, aligned_mem_base - mem_base);
+    block->freeptr = aligned_mem_base;
+    char *limit = (char*)arena + size;
+    char *aligned_limit = PTR_ALIGN_DOWN(limit, CHUNK_ALIGN);
+    block->limit = aligned_limit;
     block->next = NULL;
     block->padding = 0;
+    arena->uw_original_size = size;
     arena->uw_length = size;
     arena->uw_current_block = arena->uw_first_block = (uword_t)block;
     return make_lispobj(arena, INSTANCE_POINTER_LOWTAG);
@@ -98,10 +112,11 @@ void arena_release_memblks(lispobj arena_taggedptr)
         block = next;
     }
     arena->uw_current_block = arena->uw_first_block;
-    first->freeptr = (char*)first + sizeof (struct arena_memblk);
+    char* mem_base = (char*)first + sizeof (struct arena_memblk);
+    first->freeptr = PTR_ALIGN_UP(mem_base, CHUNK_ALIGN);
     first->next = NULL;
     arena->uw_extension_count = 0;
-    arena->uw_length = first->limit - (char*)arena;
+    arena->uw_length = arena->uw_original_size;
     ARENA_MUTEX_RELEASE(arena);
 }
 
@@ -131,7 +146,7 @@ void AMD64_SYSV_ABI sbcl_delete_arena(lispobj arena_taggedptr)
         }
         release_gc_page_table_lock();
     }
-    ARENA_DISPOSE_MEMORY(arena, arena->uw_length);
+    ARENA_DISPOSE_MEMORY(arena, arena->uw_original_size);
 }
 
 void AMD64_SYSV_ABI switch_to_arena(lispobj arena_taggedptr,
@@ -230,8 +245,12 @@ static void* memblk_claim_subrange(struct arena* a, struct arena_memblk* mem,
                     lose("Fatal: arena memory exhausted and could not obtain more memory");
                 }
                 struct arena_memblk* extension= (void*)new_mem;
-                extension->freeptr = new_mem + sizeof (struct arena_memblk);
-                extension->limit = new_mem + a->uw_growth_amount;
+                char* mem_base = new_mem + sizeof (struct arena_memblk);
+                char* aligned_mem_base = PTR_ALIGN_UP(mem_base, CHUNK_ALIGN);
+                extension->freeptr = aligned_mem_base;
+                char* limit = new_mem + a->uw_growth_amount;
+                char* aligned_limit = PTR_ALIGN_DOWN(limit, CHUNK_ALIGN);
+                extension->limit = aligned_limit;
                 extension->next = NULL;
                 extension->padding = 0;
                 a->uw_length += a->uw_growth_amount; // tally up the total length
@@ -323,16 +342,17 @@ void gc_scavenge_arenas()
     chain = arena_chain;
     if (chain) {
         do {
-            // Trace all objects below the free pointer
+            // Trace all objects below the free pointer, unless hidden
             struct arena* a = (void*)native_pointer(chain);
-            struct arena_memblk* block = (void*)a->uw_first_block;
-            while (block) {
-                // The block is its own lower bound for scavenge.
-                // Its first 4 words look like fixnums, so no need to skip 'em.
-                fprintf(stderr, "Arena @ %p: scavenging %p..%p\n",
-                        a, block, block->freeptr);
-                heap_scavenge((lispobj*)block, (lispobj*)block->freeptr);
-                block = block->next;
+            if (a->hidden == NIL) {
+                struct arena_memblk* block = (void*)a->uw_first_block;
+                do {
+                    // The block is its own lower bound for scavenge.
+                    // Its first 4 words look like fixnums, so no need to skip 'em.
+                    fprintf(stderr, "Arena @ %p: scavenging %p..%p\n",
+                            a, block, block->freeptr);
+                    heap_scavenge((lispobj*)block, (lispobj*)block->freeptr);
+                } while ((block = block->next) != NULL);
             }
             chain = a->link;
         } while (chain != NIL);
@@ -344,16 +364,15 @@ static struct result {
   int count;
 } searchresult;
 
-static lispobj find_containing_arena(lispobj ptr) {
-    if (!is_lisp_pointer(ptr) || !arena_chain) return 0;
+lispobj find_containing_arena(lispobj ptr) {
+    if (!arena_chain) return 0;
     lispobj chain = arena_chain;
     do {
         struct arena* arena = (void*)INSTANCE(chain);
         struct arena_memblk* block = (void*)arena->uw_first_block;
-        while (block) {
+        do {
             if ((lispobj)block <= ptr && (char*)ptr < block->freeptr) return chain;
-            block = block->next;
-        }
+        } while ((block = block->next) != NULL);
         chain = arena->link;
     } while (chain != NIL);
     return 0;
@@ -362,7 +381,7 @@ static lispobj find_containing_arena(lispobj ptr) {
 static lispobj target_arena;
 static inline boolean interesting_arena_pointer_p(lispobj ptr)
 {
-    lispobj arena = find_containing_arena(ptr);
+    lispobj arena = is_lisp_pointer(ptr) ? find_containing_arena(ptr) : 0;
     if (!arena) return 0; // uninteresting
     // If 'ptr' is exactly to some arena _regardless_ of which arena
     // we're actually interested in, then 'ptr' is not interesting.
@@ -466,7 +485,64 @@ int find_dynspace_to_arena_ptrs(lispobj arena, lispobj result_buffer)
     gc_start_the_world();
     searchresult.v = 0;
     int result = searchresult.count;
+    stray_pointer_detector_fn = 0;
     searchresult.count = 0;
     target_arena = 0;
     return result;
 }
+
+void arena_mprotect(lispobj arena, int option)
+{
+    int prot = option ? PROT_NONE : (PROT_READ|PROT_WRITE|PROT_EXEC);
+    struct arena* a = (void*)native_pointer(arena);
+    struct arena_memblk* blk = (void*)a->uw_first_block;
+    do {
+        char* base = PTR_ALIGN_UP((char*)blk + sizeof (struct arena_memblk), CHUNK_ALIGN);
+        char* limit = (void*)blk->limit;
+        mprotect(base, limit-base, prot);
+        // the block itself is not within [base,limit] and so can be read even if prot==PROT_NONE
+        blk = blk->next;
+    } while (blk);
+}
+
+lispobj arena_find_containing_object(lispobj arena, char* ptr)
+{
+    struct arena* a = (void*)native_pointer(arena);
+    struct arena_memblk* blk = (void*)a->uw_first_block;
+    do {
+        lispobj* where = (void*)ALIGN_UP(((uword_t)blk + sizeof (struct arena_memblk)),
+                                         CHUNK_ALIGN);
+        lispobj* limit = (void*)blk->limit;
+        while (where <  limit) {
+            if (*where == (uword_t)-1) { // filler
+                where += 2;
+            } else {
+                sword_t objsize = object_size(where);
+                if (ptr >= (char*)where && ptr < (char*)where + objsize)
+                    return compute_lispobj(where);
+                where += objsize;
+            }
+        }
+        blk = blk->next;
+    } while (blk);
+    return 0;
+}
+
+int diagnose_arena_fault(os_context_t* context, char *addr)
+{
+    lispobj arena = find_containing_arena((lispobj)addr);
+    if (!arena) return 0; // not handled
+    if (arena && ((struct arena*)native_pointer(arena))->hidden == LISP_T) {
+        arena_mprotect(arena, 0); // unprotect it and find the object
+        lispobj obj = arena_find_containing_object(arena, addr);
+        if (obj) {
+            fprintf(stderr, "access @ %p sees hidden arena object @ %p in arena %p\n",
+                    addr, (void*)obj, (void*)arena);
+            fflush(stderr);
+        }
+        //        arena_mprotect(arena, 1); // put it back the way it was
+        lisp_memory_fault_error(context, addr);
+        return 1;
+    }
+    return 0;
+}

src/runtime/linux-os.c

@@ -391,6 +391,10 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
     if (gencgc_handle_wp_violation(context, addr)) return;
 #else
     if (cheneygc_handle_wp_violation(context, addr)) return;
+#endif
+    extern int diagnose_arena_fault(os_context_t*,char*);
+#ifdef LISP_FEATURE_SYSTEM_TLABS
+    if (diagnose_arena_fault(context, addr)) return;
 #endif
     if (!handle_guard_page_triggered(context, addr))
             sbcl_fallback_sigsegv_handler(signal, info, context);

tests/arena.impure.lisp

@@ -342,6 +342,35 @@
         (exit-if-no-arenas))
       (assert (= n-deleted n-arenas)))))
 
+(defvar *another-arena* (new-arena 131072))
+(defun g (n) (make-array (the integer n) :initial-element #\z))
+(defun f (a n) (with-arena (a) (g n)))
+
+(defvar *vect* (f *another-arena* 10))
+(setf (aref *vect* 3) "foo")
+
+;;; "Hiding" an arena asserts that no references will be made to it until
+;;; unhidden and potentially rewound. So any use of it is like a use-after-free bug,
+;;; except that the memory is still there so we can figure out what went wrong
+;;; with user code. This might pass on #+-linux but has not been tested.
+(test-util:with-test (:name :arena-use-after-free :skipped-on (:not :linux))
+  (hide-arena *another-arena*)
+  (let (caught)
+    (block foo
+      (handler-bind
+          ((sb-sys:memory-fault-error
+            (lambda (c)
+              (format t "~&Uh oh spaghetti-o: tried to read @ ~x~%"
+                      (sb-sys:system-condition-address c))
+              (setq caught t)
+              (return-from foo))))
+        (aref *vect* 3)))
+    (assert caught))
+  ;; Assert that it becomes usable again
+  (unhide-arena *another-arena*)
+  (rewind-arena *another-arena*)
+  (dotimes (i 10) (f *another-arena* 1000)))
+
 ;; #+sb-devel preserves some symbols that the test doesn't care about
 ;; as the associated function will never be called.
 (defvar *ignore* '("!EARLY-LOAD-METHOD"))