tests/save3.test.sh

   1 . ./subr.sh
   2
   3 use_test_subdirectory
   4
   5 tmpcore=$TEST_FILESTEM.core
   6
   7 # This test has to do with incorrect GC of funcallable instances
   8 run_sbcl <<EOF
   9   (require :sb-bsd-sockets)
  10   (save-lisp-and-die "$tmpcore")
  11 EOF
  12 run_sbcl_with_core "$tmpcore" --noinform --no-userinit --no-sysinit \
  13     --eval "(require :sb-posix)" --quit
  14 check_status_maybe_lose "SAVE-LISP-AND-DIE" $? 0 "(saved core ran)"
  15
  16 # Verify that for funcallable instances which were moved into the
  17 # immobile text space by SAVE-LISP-AND-DIE, setting the layout
  18 # updates the GC card touched bit.
  19 # Going through instance-obsolescence stuff makes things mostly work
  20 # by accident, because (SETF %FUNCALLABLE-INSTANCE-INFO) touches
  21 # the card dirty bit when reassigning the CLOS slot vector.
  22 # We need to simulate a GC interrupt after altering the layout,
  23 # but prior to affecting the slot vector.
  24 run_sbcl <<EOF
  25   (defclass subgf (standard-generic-function) (a)
  26     (:metaclass sb-mop:funcallable-standard-class))
  27   (defgeneric myfun (a)
  28     (:generic-function-class subgf)
  29     (:method ((self integer)) 'hey-integer))
  30   (defun assign-layout ()
  31     (setf (extern-alien "verify_gens" char) 0)
  32     (defclass subgf (standard-generic-function) (a b) ; add a slot
  33       (:metaclass sb-mop:funcallable-standard-class))
  34     (defclass subgf (standard-generic-function) (a) ; remove a slot
  35       (:metaclass sb-mop:funcallable-standard-class))
  36     (let ((nl (sb-kernel:find-layout 'subgf))) ; new layout
  37       (assert (not (eq (sb-kernel:%fun-layout #'myfun) nl)))
  38       (sb-kernel:%set-fun-layout #'myfun nl)
  39       (gc)))
  40   (save-lisp-and-die "$tmpcore" :toplevel #'assign-layout)
  41 EOF
  42 run_sbcl_with_core "$tmpcore" --noinform --no-userinit --no-sysinit
  43 check_status_maybe_lose "SET-FIN-LAYOUT" $? 0 "(saved core ran)"
  44
  45 exit $EXIT_TEST_WIN