losp/los0-gc.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2003-2005,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      los0-gc.lisp
   9 ;;;; Description:   A simple GC architecture for los0.
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Sat Feb 21 17:48:32 2004
  12 ;;;;
  13 ;;;; $Id: los0-gc.lisp,v 1.62 2007/04/09 17:30:09 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (provide :los0-gc)
  18
  19 (in-package los0)
  20
  21 (defvar *gc-quiet* nil)
  22 (defvar *gc-running* nil)
  23 (defvar *gc-break* nil)
  24 (defvar *gc-trigger* nil)
  25 (defvar *gc-consistency-check* nil)
  26
  27
  28 (defmacro space-fresh-pointer (space)
  29   `(memref ,space -6 :index 2))
  30
  31 (defmacro space-other (space)
  32   `(memref ,space -6 :index 3))
  33
  34 (defun allocate-space (size &optional other-space)
  35   (let ((space (make-array size :element-type '(unsigned-byte 32))))
  36     (initialize-space space)
  37     (setf (space-other space) other-space)
  38     space))
  39
  40 (defun initialize-space (space)
  41   (setf (space-fresh-pointer space) 2)
  42   space)
  43
  44 (defun allocate-duo-space (size)
  45   (let* ((space1 (allocate-space size))
  46          (space2 (allocate-space size space1)))
  47     (setf (space-other space1) space2)
  48     space1))
  49
  50 (defun make-space (location size)
  51   "Make a space vector at a fixed location."
  52   (assert (evenp location))
  53   (macrolet ((x (index)
  54                `(memref location 0 :index ,index :type :unsigned-byte32)))
  55     (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size)
  56           (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32)
  57                           (cl:byte 8 8)
  58                           (bt:enum-value 'movitz:other-type-byte :basic-vector))))
  59   (%word-offset location #.(movitz:tag :other)))
  60
  61 (defun make-duo-space (location size)
  62   (when (oddp location)
  63     (incf location))
  64   (let ((space1 (make-space location size))
  65         (space2 (make-space (logand -4 (+ location 3 size)) size)))
  66     (initialize-space space1)
  67     (initialize-space space2)
  68     (setf (space-other space1) space2
  69           (space-other space2) space1)
  70     space1))
  71
  72 (defun duo-space-end-location (space1)
  73   (let ((space2 (space-other space1)))
  74     (max (+ (object-location space1) (length space2) 2)
  75          (+ (object-location space2) (length space2) 2))))
  76
  77 (defun test ()
  78   (warn "install..")
  79   (install-los0-consing 4)
  80   (warn "nursery: ~Z, other: ~Z"
  81         (%run-time-context-slot nil 'muerte::nursery-space)
  82         (space-other (%run-time-context-slot nil 'muerte::nursery-space)))
  83   (warn "first cons: ~Z" (funcall 'truncate #x100000000 3))
  84   (warn "second cons: ~Z" (funcall 'truncate #x100000000 3))
  85   (halt-cpu)
  86   (values))
  87
  88 (define-primitive-function los0-fast-cons ()
  89   "Allocate a cons cell of EAX and EBX from nursery-space."
  90   (macrolet
  91       ((do-it ()
  92          `(with-inline-assembly (:returns :eax)
  93            retry-cons
  94
  95 ;;             (:locally (:cmpl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30))))
  96 ;;             (:je 'no-check)
  97 ;;             (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
  98 ;;             (:movl (:edx 6) :edx); other
  99 ;;             (:cmpl 8 (:edx 2))
 100 ;;             (:jne '(:sub-program ()
 101 ;;                     (:locally (:movl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30))))
 102 ;;                     (:break)))
 103 ;;             no-check
 104
 105             ;; Set up thread-atomical execution
 106             (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'fast-cons)
 107                              (:edi (:edi-offset atomically-continuation))))
 108
 109             (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 110             (:movl (:edx 2) :ecx)
 111             (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 112                    :ecx)
 113             (:jae '(:sub-program (allocation-failed)
 114                     (:int 113)))
 115             (:movl :eax (:edx :ecx 2))
 116             (:movl :ebx (:edx :ecx 6))
 117             (:addl 8 :ecx)
 118             (:movl :ecx (:edx 2))       ; Commit allocation
 119             (:leal (:edx :ecx -5) :edx)
 120             ;; Exit thread-atomical
 121             (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 122             (:movl :edx :eax)
 123             (:ret))))
 124     (do-it)))
 125
 126
 127 (defun trigger-full-newspace (free-space)
 128   "Make it so that there's only free-space words left before newspace is full."
 129   (unless *gc-running*
 130     (let ((trigger (if (consp *gc-trigger*)
 131                        (pop *gc-trigger*)
 132                      *gc-trigger*)))
 133       (when trigger
 134         (macrolet
 135             ((do-it ()
 136                `(with-inline-assembly (:returns :nothing)
 137                  retry
 138                   (:compile-form (:result-mode :eax) (+ free-space trigger))
 139                   (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 140                   (:testl ,(logxor #xffffffff
 141                                    (* #xfff movitz:+movitz-fixnum-factor+))
 142                           :eax)
 143                   (:jnz '(:sub-program () (:int 64)))
 144                   (:addl 4 :eax)
 145                   (:andl -8 :eax)
 146                   (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 147                          :ecx)
 148                   (:subl :eax :ecx)
 149                   (:movl (:edx 2) :ebx)
 150                   (:cmpl :ecx :ebx)
 151                   (:jc '(:sub-program ()
 152                          ;; Current newspace was too full, so trigger a GC.
 153                          (:int 113)
 154                          (:jmp 'retry)))
 155                   (:movl :ecx (:edx 2))
 156                   (:addl 8 :ebx)
 157                  fill-loop
 158                   (:movl :edi (:edx :ebx -6))
 159                   (:addl 4 :ebx)
 160                   (:cmpl :ebx :ecx)
 161                   (:ja 'fill-loop)
 162                   )))
 163           (do-it))))))
 164
 165
 166 (define-primitive-function los0-cons-pointer ()
 167   "Return in EAX the next object location with space for EAX words, with tag 6.
 168 Preserve ECX."
 169   (macrolet
 170       ((do-it ()
 171          `(with-inline-assembly (:returns :multiple-values)
 172             (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically?
 173             (:je '(:sub-program ()
 174                    (:int 63)))          ; This must be called inside atomically.
 175             (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 176             (:movl (:edx 2) :ebx)
 177             (:leal (:ebx :eax 4) :eax)
 178             (:andl -8 :eax)
 179             (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 180                    :eax)
 181             (:ja '(:sub-program (probe-failed)
 182                    (:int 113)
 183                    (:int 63)))
 184             (:movl #xabbabee3 (:edx :ebx 8 ,movitz:+other-type-offset+)) ; a recognizable illegal value?
 185             (:leal (:edx :ebx 8) :eax)
 186             (:ret))))
 187     (do-it)))
 188
 189 (define-primitive-function los0-cons-commit ()
 190   "Commit allocation of ECX/fixnum words.
 191 Preserve EAX and EBX."
 192   (macrolet
 193       ((do-it ()
 194          `(with-inline-assembly (:returns :multiple-values)
 195             (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically?
 196             (:je '(:sub-program ()
 197                    (:int 63)))          ; This must be called inside atomically.
 198             (:addl ,movitz:+movitz-fixnum-factor+ :ecx)
 199             (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 200             (:andl -8 :ecx)
 201             (:addl (:edx 2) :ecx)
 202             (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 203                    :ecx)
 204             (:ja '(:sub-program (commit-failed)
 205                    (:int 113)
 206                    (:int 63)))
 207             (:movl :ecx (:edx 2))
 208             (:leal (:edx :ecx) :ecx)
 209             (:ret))))
 210     (do-it)))
 211
 212 (define-primitive-function los0-box-u32-ecx ()
 213   "Make u32 in ECX into a fixnum or bignum in EAX."
 214   (macrolet
 215       ((do-it ()
 216          `(with-inline-assembly (:returns :multiple-values)
 217             (:cmpl ,movitz:+movitz-most-positive-fixnum+ :ecx)
 218             (:ja 'not-fixnum)
 219             (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax)
 220             (:ret)
 221            not-fixnum
 222             (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'box-u32-ecx)
 223                              (:edi (:edi-offset atomically-continuation))))
 224             (:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
 225             (:movl (:edx 2) :eax)
 226             (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
 227                    :eax)
 228             (:jae '(:sub-program ()
 229                     (:int 113)))
 230             (:movl ,(dpb movitz:+movitz-fixnum-factor+
 231                          (byte 16 16) (movitz:tag :bignum 0))
 232                    (:edx :eax 2))
 233             (:movl :ecx (:edx :eax 6))
 234             (:addl 8 :eax)
 235             (:movl :eax (:edx 2))       ; Commit allocation
 236             (:leal (:edx :eax) :eax)
 237             ;; Exit thread-atomical
 238             (:locally (:movl 0 (:edi (:edi-offset atomically-continuation))))
 239             (:ret))))
 240     (do-it)))
 241
 242 (defvar *gc-stack* nil)
 243 (defvar *gc-stack2* nil)
 244
 245 (defmacro with-hack-space ((&key (size 409600)) &body body)
 246   `(let* ((id (with-inline-assembly (:returns :eax) (:movl :esp :eax)))
 247           (save-space (%run-time-context-slot nil 'muerte::nursery-space))
 248           (hack-space (make-duo-space (duo-space-end-location save-space) ,size)))
 249      (warn "[~A] hack-space ~Z from ~Z/~Z: ~A" id hack-space save-space (space-other save-space) ',body)
 250      (unwind-protect
 251           (progn
 252             (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space)
 253             ,@body)
 254        (warn "[~A] hack-space done." id)
 255        (setf (%run-time-context-slot nil 'muerte::nursery-space) save-space))))
 256
 257 (defun install-los0-consing (&key (context (current-run-time-context))
 258                                   (kb-size 1024)
 259                                   duo-space)
 260   "Install the 'Los0' GC architecture on run-time-context CONTEXT.
 261 Either use an explicitly provided DUO-SPACE, or allocate a fresh
 262 duo-space where each space is KB-SIZE kilobytes."
 263   (setf (exception-handler 113)
 264     (lambda (exception interrupt-frame)
 265       (declare (ignore exception interrupt-frame))
 266       (without-interrupts
 267         (let ((muerte::*active-condition-handlers* nil)
 268               (*debugger-hook* nil)
 269               (*standard-output* *terminal-io*))
 270           (cond
 271             (*gc-running*
 272              (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space))
 273                     (hack-space (make-duo-space (duo-space-end-location full-space) 102400)))
 274                (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space)
 275                (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z"
 276                       full-space hack-space)))
 277             (t (let ((*gc-running* t))
 278                  (unless *gc-quiet*
 279                    (format t "~&;; GC ~Z.." (%run-time-context-slot nil 'muerte::nursery-space)))
 280                  (let* ((space0 (%run-time-context-slot nil 'nursery-space))
 281                         (space1 (space-other space0)))
 282                    (unless (= 2 (space-fresh-pointer space1))
 283                      (with-hack-space ()
 284                        (error "PRE space-other is not initialized: ~S" (space-fresh-pointer space1)))))
 285                  (unwind-protect
 286                       (stop-and-copy)
 287                    (let* ((space0 (%run-time-context-slot nil 'nursery-space))
 288                           (space1 (space-other space0)))
 289                      (unless (= 2 (space-fresh-pointer space1))
 290                        (with-hack-space ()
 291                          (error "UP space-other is not initialized: ~S" (space-fresh-pointer space1))))
 292                      )))))
 293           (if *gc-break*
 294               (break "GC break.")
 295               (loop ; This is  a nice opportunity to poll the keyboard..
 296                  (case (muerte.x86-pc.keyboard:poll-char)
 297                    ((#\escape)
 298                     (break "Los0 GC keyboard poll."))
 299                    ((nil)
 300                     (return)))))))))
 301   (let* ((actual-duo-space (or duo-space
 302                                (allocate-duo-space (* kb-size #x100))))
 303          (last-location (object-location (cons 1 2))))
 304     (macrolet ((install-primitive (name slot)
 305                  `(let ((code-vector (symbol-value ',name)))
 306                     (check-type code-vector code-vector)
 307                     (if (eq context (current-run-time-context))
 308                         ;; The point of this is to not trigger CLOS bootstrapping.
 309                         (setf (%run-time-context-slot nil ',slot) code-vector)
 310                       (setf (%run-time-context-slot context ',slot) code-vector)))))
 311       (install-primitive los0-fast-cons muerte::fast-cons)
 312       (install-primitive los0-box-u32-ecx muerte::box-u32-ecx)
 313       (install-primitive los0-cons-pointer muerte::cons-pointer)
 314       (install-primitive los0-cons-commit muerte::cons-commit))
 315     (if (eq context (current-run-time-context))
 316         (setf (%run-time-context-slot nil 'muerte::nursery-space)
 317           actual-duo-space)
 318       (setf (%run-time-context-slot context 'muerte::nursery-space)
 319         actual-duo-space))
 320     ;; Pretend that the heap stops here, so that we don't have to scan
 321     ;; the entire tail end of memory, which isn't going to be used.
 322     (setf (cdar muerte::%memory-map-roots%) last-location))
 323   (values))
 324
 325 (defun object-in-space-p (space object)
 326   (check-type space (simple-array (unsigned-byte 32) 1))
 327   (and (typep object 'pointer)
 328        (<= (+ 2 (object-location space))
 329            (object-location object)
 330            (+ 1 (object-location space)
 331               (array-dimension space 0)))))
 332
 333 (defun report-nursery (x location)
 334   "Write a message if x is inside newspace."
 335   (when (object-in-space-p (%run-time-context-slot nil 'nursery-space) x)
 336     (format t "~&~Z: ~S: ~S from ~S" x (type-of x) x location))
 337   x)
 338
 339 (defun report-inactive-space (x location)
 340   "Check that x is not pointing into (what is presumably) oldspace."
 341   (when (object-in-space-p (space-other (%run-time-context-slot nil 'nursery-space)) x)
 342     (break "~Z: ~S: ~S from ~S" x (type-of x) x location))
 343   x)
 344
 345 (defun location-finder (find-location)
 346   (lambda (x location)
 347     (when (location-in-object-p x find-location)
 348       (break "The location ~S is in the object at ~Z referenced from location ~S."
 349              find-location x location))
 350     x))
 351
 352 #+ignore
 353 (defun tenure ()
 354   (install-old-consing)
 355   (install-los0-consing))
 356
 357 #+ignore
 358 (defun kill-the-newborns ()
 359   (let* ((oldspace (%run-time-context-slot nil 'nursery-space))
 360          (newspace (space-other oldspace)))
 361     (setf (%run-time-context-slot nil 'nursery-space) newspace)
 362     (flet ((zap-oldspace (x location)
 363              (declare (ignore location))
 364              (if (object-in-space-p oldspace x)
 365                  nil
 366                x)))
 367       (map-header-vals #'zap-oldspace 0 (malloc-end))
 368       (map-stack-vector #'zap-oldspace nil (current-stack-frame))
 369       (initialize-space oldspace)
 370       (values))))
 371
 372
 373 (defparameter *x* (make-array #x1000 :fill-pointer 0))          ; Have this in static space.
 374 ;;;(defparameter *xx* #4000(nil))               ; Have this in static space.
 375
 376 (defvar *gc-x1* nil)
 377 (defvar *gc-x2* nil)
 378
 379 (defparameter *code-vector-foo* 0)
 380 (defvar *old-code-vectors* #250(nil))
 381 (defvar *new-code-vectors* #250(nil))
 382
 383 (defun stop-and-copy (&optional evacuator)
 384   (setf (fill-pointer *x*) 0)
 385   (setf (fill-pointer *old-code-vectors*) 0)
 386   (multiple-value-bind (newspace oldspace)
 387       (without-interrupts
 388         (let* ((space0 (%run-time-context-slot nil 'nursery-space))
 389                (space1 (space-other space0)))
 390           (check-type space0 (simple-array (unsigned-byte 32) 1))
 391           (check-type space1 (simple-array (unsigned-byte 32) 1))
 392           (assert (eq space0 (space-other space1)))
 393           (unless (= 2 (space-fresh-pointer space1))
 394             (with-hack-space ()
 395               (error "space1 is not initialized: ~S" (space-fresh-pointer space1))
 396               nil))
 397           (setf (%run-time-context-slot nil 'nursery-space) space1)
 398           (values space1 space0)))
 399     ;; Evacuate-oldspace is to be mapped over every potential pointer.
 400     (let ((*code-vector-foo* (incf *code-vector-foo* 2))
 401           (evacuator
 402            (or evacuator
 403                (lambda (x location)
 404                  "If x is in oldspace, migrate it to newspace."
 405                  (declare (ignore location))
 406                  (cond
 407                   ((null x)
 408                    nil)
 409                   ((object-in-space-p newspace x)
 410                    x)
 411                   #+ignore ((and (typep x 'code-vector)
 412                                  (not (object-in-space-p oldspace x))
 413                                  (not (object-in-space-p newspace x))
 414                                  (= (ldb (byte 12 0) (object-location x))
 415                                     (ldb (byte 12 0) *code-vector-foo*))
 416                                  (not (eq x (funobj-code-vector #'stop-and-copy)))
 417                                  (not (eq x (symbol-value 'muerte::default-interrupt-trampoline)))
 418                                  (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x))))
 419                             (let ((p (position (object-location x) *old-code-vectors*)))
 420                               (if p
 421                                   (aref *new-code-vectors* p)
 422                                   (setf (aref *new-code-vectors*
 423                                               (vector-push (object-location x) *old-code-vectors*))
 424                                         (let ((new (shallow-copy x)))
 425                                           (warn "[~S] Migrating ~@[~S ~]~Z => ~Z."
 426                                                 location
 427                                                 (muerte::locate-function (object-location x))
 428                                                 x new)
 429                                           new)))))
 430                   ((not (object-in-space-p oldspace x))
 431                    x)
 432                   #+ignore ((when (typep x 'run-time-context)
 433                               (warn "Scavenging ~S" x)))
 434                   (t (or (and (eq (object-tag x)
 435                                   (ldb (byte 3 0)
 436                                        (memref (object-location x) 0 :type :unsigned-byte8)))
 437                               (let ((forwarded-x (memref (object-location x) 0)))
 438                                 (and (object-in-space-p newspace forwarded-x)
 439                                      forwarded-x)))
 440                          (let ((forward-x (shallow-copy x)))
 441                            (when (and *gc-consistency-check*
 442                                       (typep x 'muerte::pointer))
 443                              (let ((a *x*))
 444                                (vector-push (%object-lispval x) a)
 445                                (vector-push (memref (object-location x) 0 :type :unsigned-byte32) a)
 446                                (assert (vector-push (%object-lispval forward-x) a))))
 447                            (setf (memref (object-location x) 0) forward-x)
 448                            forward-x))))))))
 449       ;; Scavenge roots
 450       (with-simple-restart (nil "Scanning stack.")
 451         (map-stack-vector evacuator nil (current-stack-frame)))
 452       (with-simple-restart (nil "Scanning heap.")
 453         (dolist (range muerte::%memory-map-roots%)
 454           (map-header-vals evacuator (car range) (cdr range))))
 455       ;; Scan newspace, Cheney style.
 456       (loop with newspace-location of-type index = (+ 2 (object-location newspace))
 457           with scan-pointer of-type index = 2
 458           as fresh-pointer of-type index = (space-fresh-pointer newspace)
 459           while (< scan-pointer fresh-pointer)
 460           do (let ((start (+ newspace-location scan-pointer))
 461                    (end (+ newspace-location (space-fresh-pointer newspace))))
 462                (map-header-vals evacuator start end)
 463                (setf *gc-x1* start)
 464                (setf *gc-x2* end))
 465            (setf scan-pointer fresh-pointer))
 466       (when *gc-consistency-check*
 467         ;; Consistency check..
 468         (map-stack-vector (lambda (x foo)
 469                             (declare (ignore foo))
 470                             x)
 471                           nil
 472                           (current-stack-frame))
 473         (with-simple-restart (continue "Skip GC consistency check.")
 474           (without-interrupts
 475             (let ((a *x*))
 476               ;; First, restore the state of old-space
 477               (do ((end (- (length a) 2))
 478                    (i 0 (+ i 3)))
 479                   ((>= i end))
 480                 (let ((old (%lispval-object (aref a i)))
 481                       (old-class (aref a (+ i 1))))
 482                   (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class)))
 483               ;; Then, check that each migrated object is equalp to its new self.
 484               (do ((i 0 (+ i 3)))
 485                   ((>= i (length a)))
 486                 (let ((old (%lispval-object (aref a i)))
 487                       (new (%lispval-object (aref a (+ i 2)))))
 488                   (unless (and (object-in-space-p newspace new)
 489                                (not (object-in-space-p newspace old))
 490                                (objects-equalp old new))
 491                     (let ((*evacuator* evacuator)
 492                           (*old* old)
 493                           (*new* new)
 494                           (*old-class* (aref a (+ i 1))))
 495                       (declare (special *old* *new* *old-class* *evacuator*))
 496                       (error "GC consistency check failed:
 497 old object: ~Z: ~S
 498 new object: ~Z: ~S
 499 equalp: ~S
 500 oldspace: ~Z, newspace: ~Z, i: ~D"
 501                              old old new new (objects-equalp old new) oldspace newspace i))))))
 502             (map-header-vals (lambda (x y)
 503                                (declare (ignore y))
 504                                (when (location-in-object-p (space-other (%run-time-context-slot nil 'nursery-space))
 505                                                            (object-location x))
 506                                  (break "Seeing old object in values-vector: ~Z" x))
 507                                x)
 508                              #x38 #xb8)
 509             #+ignore
 510             (let* ((stack (%run-time-context-slot nil 'muerte::stack-vector))
 511                    (stack-start (- (length stack) (muerte::current-control-stack-depth))))
 512               (do ((i 0 (+ i 3)))
 513                   ((>= i (length a)))
 514                 (let* ((offender? (aref a i))
 515                        (offender-index (position offender? stack :start stack-start)))
 516                   (when offender-index
 517                     (break "Seeing old object ~S in current stack at ~S, new is ~S"
 518                            offender?
 519                            (+ (object-location stack)
 520                               offender-index 2)
 521                            (aref a (+ i 2))))))
 522               (loop for i from stack-start below (length stack)
 523                   as o = (aref stack i)
 524                   do (when (and (typep o 'pointer)
 525                                 (location-in-object-p oldspace (object-location o)))
 526                        (break "Seeing old (unmapped) object ~Z in stack at ~S."
 527                               o (+ (object-location stack) i 2))))))))
 528       (loop for o across *old-code-vectors*
 529           for n across *new-code-vectors*
 530           do (setf (memref o 0) (memref n -6))
 531              (fill (muerte::%location-object o 6) #xcc))
 532       ;; GC completed, oldspace is evacuated.
 533       (unless *gc-quiet*
 534         (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2))
 535               (new-size (truncate (- (space-fresh-pointer newspace) 2) 2)))
 536           (format t "Old space: ~/muerte:pprint-clumps/, new space: ~
 537 ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
 538                   old-size new-size (- old-size new-size))))
 539       (dolist (hook *gc-hooks*)
 540         (funcall hook))
 541       (initialize-space oldspace)
 542       (when *gc-consistency-check*
 543         (fill oldspace #x13 :start 2)
 544         ;; (setf *gc-stack2* *gc-stack*)
 545         (setf *gc-stack* (muerte::copy-current-control-stack))
 546         #+ignore (setf (fill-pointer *xx*) (fill-pointer *x*))
 547         #+ignore (replace *xx* *x*))))
 548   (values))
 549
 550 (defun simple-stop-and-copy (newspace oldspace)
 551   (flet ((evacuator (x)
 552            "If x is in oldspace, migrate it to newspace."
 553            (if (not (object-in-space-p oldspace x))
 554                x
 555              (or (and (eq (object-tag x)
 556                           (memref (object-location x) 0 :type :tag))
 557                       (let ((forwarded-x (memref (object-location x) 0)))
 558                         (and (object-in-space-p newspace forwarded-x)
 559                              forwarded-x)))
 560                  (setf (memref (object-location x) 0)
 561                    (shallow-copy x))))))
 562     ;; Scavenge roots
 563     (map-stack-vector #'evacuator nil (current-stack-frame))
 564     (dolist (range muerte::%memory-map-roots%)
 565       (map-header-vals #'evacuator (car range) (cdr range)))
 566     ;; Scan newspace, Cheney style.
 567     (loop with newspace-location = (+ 2 (object-location newspace))
 568         with scan-pointer = 2
 569         as fresh-pointer = (space-fresh-pointer newspace)
 570         while (< scan-pointer fresh-pointer)
 571         do (map-header-vals #'evacuator
 572                             (+ newspace-location scan-pointer)
 573                             (+ newspace-location (space-fresh-pointer newspace)))
 574            (setf scan-pointer fresh-pointer))
 575     (initialize-space oldspace)
 576     (values)))
 577
 578
 579 (defun find-object-by-location (location &key (continuep t) (breakp nil))
 580   "Scan the heap for a (pointer) object that matches location.
 581 This is a debugging tool."
 582   (let ((results nil))
 583     (flet ((searcher (x ignore)
 584              (declare (ignore ignore))
 585              (when (and (typep x '(or muerte::tag1 muerte::tag6 muerte::tag7))
 586                         (not (eq x (%run-time-context-slot nil 'muerte::nursery-space)))
 587                         (location-in-object-p x location)
 588                         (not (member x results)))
 589                (push x results)
 590                (funcall (if breakp #'break #'warn)
 591                         "Found pointer ~Z of type ~S at location ~S."
 592                         x (type-of x) (object-location x)))
 593              x))
 594       (handler-bind
 595           ((serious-condition (lambda (c)
 596                                 (when (and continuep
 597                                            (find-restart 'muerte::continue-map-header-vals))
 598                                   (warn "Automatic continue from scanning error: ~A" c)
 599                                   (invoke-restart 'muerte::continue-map-header-vals)))))
 600         (dolist (range muerte::%memory-map-roots%)
 601           (map-header-vals #'searcher (car range) (cdr range)))
 602         (let ((nursery (%run-time-context-slot nil 'muerte::nursery-space)))
 603           (map-header-vals #'searcher
 604                            (+ 4 (object-location nursery))
 605                            (+ 4 (object-location nursery) (space-fresh-pointer nursery))))
 606         (map-stack-vector #'searcher nil (current-stack-frame))))
 607     results))
 608
 609 (defun report-lispval (lispval &optional breakp newspace)
 610   (let* ((location (truncate lispval 4))
 611          (newspace (or newspace (%run-time-context-slot nil 'muerte::nursery-space)))
 612          (oldspace (space-other newspace)))
 613     (cond
 614      ((location-in-object-p newspace location)
 615       (format t "#x~X is in newspace ~Z." lispval newspace))
 616      ((location-in-object-p oldspace location)
 617       (funcall (if breakp 'break 'warn) "#x~X is in oldspace ~Z." lispval oldspace))
 618      (t (funcall (if breakp 'break 'warn) "#x~X is neither old nor new?" lispval))))
 619   (values))
 620