mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
48 lines
2 KiB
Common Lisp
48 lines
2 KiB
Common Lisp
|
|
(defun adjacent-barriers ()
|
|
(let ((o (list 1)))
|
|
(setf (car o) (list 100))
|
|
(setf (car o) (make-array 200 :element-type 'fixnum))
|
|
(setf (cdr o) (list 100 2))))
|
|
|
|
(with-test (:name :adjacent-barrier-elimination-sticky-marks
|
|
:skipped-on (or :gc-stress
|
|
(:not :soft-card-marks)))
|
|
(let ((pre_verify_gen_0 (extern-alien "pre_verify_gen_0" int)))
|
|
(setf (extern-alien "pre_verify_gen_0" int) 1)
|
|
(loop repeat 1000000
|
|
do (adjacent-barriers))
|
|
(setf (extern-alien "pre_verify_gen_0" int) pre_verify_gen_0)))
|
|
|
|
|
|
;;; The layout of FOO must not get promoted from gen0 to gen1.
|
|
;;; Due to random variation, there might be a gc-with-promotion cycle
|
|
;;; just after the defstruct. So prevent that.
|
|
#+generational (setf (generation-number-of-gcs-before-promotion 0) 1000000)
|
|
(defstruct foo x)
|
|
(defun get-layouts-for-test ()
|
|
;; Return a young layout and an old layout
|
|
(vector (sb-kernel:find-layout 'foo)
|
|
(sb-kernel:find-layout 'class)))
|
|
|
|
(with-test (:name :compact-instance-header-layout
|
|
:skipped-on (or :win32
|
|
:gc-stress
|
|
(:not (:and :gencgc :compact-instance-header :soft-card-marks)))
|
|
:fails-on (and :darwin :x86-64)) ;; can't compile the .so
|
|
(unless (probe-file "gc-testlib.so")
|
|
(sb-ext:run-program "sh"
|
|
`("run-compiler.sh" "-sbcl-pic" "-sbcl-shared"
|
|
#+darwin ,@'("-flat_namespace" "-undefined" "suppress" "-mmacosx-version-min=10.7")
|
|
"-I../src/runtime"
|
|
"gc-testlib.c" "-o" "gc-testlib.so")
|
|
:search t
|
|
:output t :error t))
|
|
(load-shared-object (truename "gc-testlib.so"))
|
|
#+sb-thread (sb-impl::finalizer-thread-stop)
|
|
(let ((v (get-layouts-for-test)))
|
|
(sb-sys:with-pinned-objects (v)
|
|
(alien-funcall (extern-alien "compact_instance_layout_pointer_test"
|
|
(function int unsigned))
|
|
(sb-kernel:get-lisp-obj-address v)))))
|