;;; -*- Mode:LISP; Package:LAMBDA; Base:8; readtable: ZL -*-
;;; (c) Copyright 1985, Lisp Machine Incorporated.

(defconstant uc-scavenger '(

(locality a-mem)
a-scavenge-region (0)
a-scavenge-region-origin (0)
a-scavenge-region-free-pointer (0)
a-scavenge-object (0)
a-scavenge-next-object (0)
a-scavenge-object-bound (0)
a-scavenge-block-bound (0)
a-scavenge-work (0)
a-scavenge-volatility (0)
a-scavenge-state (0)  ;0 "normal", 2 resume scavenging page, 3 resume scavenging carefully
a-scavenge-block-return-pc (0)
a-scavenger-start-time (0)
a-scavenger-start-disk-time (0)
a-scavenger-transporter-start-time (0)
a-scavenger-transporter-start-disk-time (0)
a-scavenge-page-resident (0)
a-scavenge-idle-flag (0)
(locality i-mem)

     (misc-inst-entry %gc-scav-reset)
reset-scavenger
        ((m-k) q-pointer pdl-pop)
        (jump-not-equal m-k a-scavenge-region xfalse)
        (jump-equal m-k a-zero xfalse)
        (call invalidate-cons-caches)
     ;; Set scavenge pointer back to object boundary.
        (call-xct-next store-region-gc-pointer)
       ((m-1) a-scavenge-object)
        ((a-scavenge-state) m-zero)
     ;; Check to see if we're beyond free pointer.
        ((vma-start-read) add m-k a-v-region-free-pointer)
        (check-page-read)
        ((m-1) output-selector-mask-25 add md a-scavenge-region-origin)
     ;; If we're still below the free pointer, don't worry about it.
        (jump-greater-or-equal m-1 a-scavenge-next-object xfalse)
     ;; Past free pointer, set scavenge-pointer = free-pointer and reset scavenger.
        (call-return store-region-gc-pointer xtrue)

     (misc-inst-entry %better-gc-scavenge)
better-scavenge
     ;; This should scavenge even if interrupts are disabled, since it's primarily called
     ;; from the scheduler, which runs uninterruptibly.
	((a-scavenge-work) q-pointer pdl-pop)
	(call-xct-next scavenge-even-without-interrupts)
       ((a-scavenge-idle-flag) pdl-pop)
	(jump xfalse)

     (misc-inst-entry %gc-scavenge)
scavenge
     ;; This should scavenge even if interrupts are disabled, since it's primarily called
     ;; from the scheduler, which runs uninterruptibly.
	((a-scavenge-work) q-pointer pdl-pop)
	(call-xct-next scavenge-even-without-interrupts)
       ((a-scavenge-idle-flag) a-v-nil)
	(jump xfalse)

scavenge-while-consing
     ;; Don't scavenge if interrupts disabled, to help macrocode that just
     ;; does without-interrupts (and not without-scavenging) during critical periods.
        ((m-tem) dpb m-zero q-all-but-typed-pointer a-inhibit-scheduling-flag)
        (popj-not-equal m-tem a-v-nil)
        ((a-scavenge-idle-flag) a-v-nil)
scavenge-even-without-interrupts
     ;; Extra-PDL trap depends on this test to inhibit scavenge during cons.
        (popj-if-bit-set m-transport-flag)
        ((m-tem) dpb m-zero q-all-but-typed-pointer a-inhibit-scavenging-flag)
        (popj-not-equal m-tem a-v-nil)
        ((m-tem) dpb m-zero q-all-but-typed-pointer a-gc-flip-ready)
        (popj-not-equal m-tem a-v-nil)
        (call scavenge-save)
        (jump-equal-xct-next m-zero a-scavenge-state scavenge-regions)
       ((a-scavenge-volatility) dpb m-zero (byte 36 2) a-gc-switches)
resume-scavenge
        (call load-region-scavenge-parameters)
        ((q-r) a-scavenge-state)
        (jump-equal-xct-next q-r (a-constant 2) scavenge-block)
       ((micro-stack-data-push) a-scavenge-block-return-pc)
     ;; Scavenging a PDL (carefully).  Scavenge limit may have changed since last invocation.
        (call-xct-next structure-info)
       ((m-t) a-scavenge-object)
        (jump-xct-next scavenge-block)
       ((a-scavenge-block-bound) add m-3 a-scavenge-object)

(begin-comment) Zwei Lossage (end-comment)

scavenge-next-region
        (call-xct-next store-region-gc-pointer)
       ((m-1) a-scavenge-region-free-pointer)
scavenge-regions
        ((a-scavenge-region) (a-constant 400))
scavenge-regions-loop
        ((a-scavenge-region q-r) add m-minus-one a-scavenge-region)
        (jump-less q-r a-zero finish-scavenge)
        ((vma-start-read) add q-r a-v-region-bits)
        (illop-if-page-fault)
        (jump-if-bit-clear (lisp-byte %%region-scavenge-enable) md scavenge-regions-loop)
        (call-xct-next load-region-scavenge-parameters)
       ((pdl-push) md)
        (jump-if-bit-set-xct-next (lisp-byte %%region-scavenge-carefully) pdl-pop scavenge-region-carefully)
       (jump-greater-or-equal m-1 a-scavenge-region-free-pointer scavenge-regions-loop)

scavenge-next-page
     ;; Run scavenge-queue, spending scavenge units.  Doing it this often helps locality.
        (call-not-equal-xct-next m-minus-one a-scavenge-queue-pointer run-scavenge-queue)
       ((a-scavenge-queue-work) a-scavenge-work)
        ((a-scavenge-work) a-scavenge-queue-work)
     ;; If the page we just scavenged was not resident before, flush it.  Now is the best time
     ;; to do it -- the scavenge queue has already run, which might reference the page.
        (jump-not-equal a-scavenge-page-resident m-zero scavenge-dont-flush)
scavenge-flush-page
        (call-xct-next search-page-hash-table)
       ((m-t) sub m-1 (a-constant 400))
     ;; Don't do it if page has no valid PHT entry.
	(jump-if-bit-clear pht1-valid-bit md scavenge-dont-flush)
     ;; Only flush normal pages.  In particular, don't do wired pages.
        ((m-tem) pht1-swap-status-code md)
        (jump-not-equal m-tem (a-constant (eval %pht-swap-status-normal)) scavenge-dont-flush)
        ((md-start-write) selective-deposit md pht1-all-but-age-and-swap-status-code
	                  (a-constant (eval %pht-swap-status-flushable)))
        (illop-if-page-fault)
	((md) md)		;wait for memory cycle to finish
#+exp	(no-op)
     ;; Flush level-2 map.
	((#+lambda l2-map-control
	  #+exp vma-write-l2-map-control) (a-constant 0))
scavenge-dont-flush
        (call-greater-or-equal m-1 a-scavenge-region-free-pointer scavenge-check-region-free-pointer)
     ;; Scavenging level 0, don't bother searching for worthwhile pages.  (Code below depends on this.)
        (jump-equal-xct-next m-zero a-scavenge-volatility scavenge-page)
       ((m-1) dpb m-zero (byte 10 0) a-1)

scavenge-page-search
     ;Read an entire word from the a-v-virtual-page-volatility table.
     ;This corresponds to a "sector".
	((m-tem3) (byte (difference q-pointer-width 14) 14) m-1)
	((vma-start-read) add m-tem3 a-v-virtual-page-volatility)
	(illop-if-page-fault)
        ((m-tem3) q-page-number m-1)
	((m-tem3) dpb m-tem3 (byte 4 1) a-zero)	       ;Position in human sense.
     ;; If all pages in this sector have zero volatility, skip it.
        (jump-equal-xct-next md a-zero scavenge-skip-sector)
       ((m-3) add m-1 (a-constant (eval (* 20 400))))
        ((m-tem3 q-r) sub (m-constant 40) a-tem3)      ;Complement for shifter.
     ;; The hardware form of the byte-position is also the correct byte-length, since we want the
     ;; upper (- 32. position) bits.  However, the Lambda actually wants 1- this value.
#+lambda((q-r) sub q-r (a-constant 1))
        ((oa-reg-low) dpb q-r oal-bytl-1 a-tem3)
        ((md) byte-inst md a-zero)
scavenge-page-pipeline
        ((m-tem) (byte 2 0) md)
        (jump-greater-or-equal m-tem a-scavenge-volatility scavenge-page-0)
        ((m-tem) (byte 2 2) md)
        (jump-greater-or-equal m-tem a-scavenge-volatility scavenge-page-1)
        ((m-tem) (byte 2 4) md)
        (jump-greater-or-equal m-tem a-scavenge-volatility scavenge-page-2)
        ((m-tem) (byte 2 6) md)
        (jump-greater-or-equal m-tem a-scavenge-volatility scavenge-page-3)
        ((md) (byte 24. 8.) md)
        (jump-not-equal-xct-next md a-zero scavenge-page-pipeline)
       ((m-1) add m-1 (a-constant 2000))
scavenge-skip-sector
     ;; None of the remaining pages in this sector contain volatile pointers, skip to next sector.
        ((m-1) dpb m-zero (byte 14 0) a-3)
        (jump-xct-next scavenge-page-search)
       (call-greater-or-equal m-1 a-scavenge-region-free-pointer scavenge-check-region-free-pointer)

scavenge-page-3
        ((m-1) add m-1 (a-constant 400))
scavenge-page-2
        ((m-1) add m-1 (a-constant 400))
scavenge-page-1
        ((m-1) add m-1 (a-constant 400))
scavenge-page-0
     ;; If page is already resident in physical memory, set a-scavenge-page-resident to 1,
     ;; otherwise set it to 0.  This is used later to decide whether to flush the page.
        (call-xct-next search-page-hash-table)
       ((m-t) q-pointer m-1)
        (jump-if-bit-clear-xct-next pht1-valid-bit md scavenge-page)
       ((a-scavenge-page-resident) (a-constant 0))
        ((a-scavenge-page-resident) (a-constant 1))
scavenge-page
        (call-greater-or-equal m-1 a-scavenge-region-free-pointer scavenge-check-region-free-pointer)
     ;; Reset volatility of this page to zero.
        ((a-gc-trap-vma) m-1)
        (call-xct-next update-page-volatility)
       ((a-gc-trap-md-volatility) m-zero)

     ;; Look up Initial-Qs, First-Header in structure handles.
        (call-xct-next read-structure-handle)
       ((m-3) q-page-number m-1)

        ((a-scavenge-next-object) add m-1 a-5)		   ;First-Object.
        ((a-scavenge-object-bound) add m-1 a-6)		   ;Initial-Qs.
        ((a-scavenge-object) m-1)			   ;Compatability with careful code.
        ((a-scavenge-block-bound q-r) add m-1 (a-constant 400))
        ((a-scavenge-state) (a-constant 2))
        (jump-less-or-equal-xct-next q-r a-scavenge-region-free-pointer scavenge-block)
       ((micro-stack-data-push) (a-constant (i-mem-loc scavenge-next-page)))
     ;; Close to end, make sure we have the latest and greatest free-pointer for comparisons.
        (call-xct-next load-scavenge-region-free-pointer)   ;transparent to q-r.
       ((m-k) a-scavenge-region)
        (jump-less-or-equal q-r a-scavenge-region-free-pointer scavenge-block)
     ;; Really on last page in region, scavenge the partial page.
        (jump-xct-next scavenge-block)
       ((a-scavenge-block-bound) a-scavenge-region-free-pointer)


;;; Careful scavenging.

scavenge-region-carefully
scavenge-carefully-page-loop
        (call-greater-or-equal m-1 a-scavenge-region-free-pointer scavenge-check-region-free-pointer)
        (call-xct-next read-page-volatility)
       ((m-lam) q-page-number m-1)
        (jump-less-than-xct-next m-tem a-scavenge-volatility scavenge-carefully-page-loop)
       ((m-1) add m-1 (a-constant 400))
        ((m-1) sub m-1 (a-constant 400))		   ;Undo superfluous add.

     ;; We found a volatile page.  We have to scavenge the entire containing object, because
     ;; we can't trust the structure handles to indicate boxedness or unboxedness.  Search back
     ;; through pages until we find the start of the object.  Note: objects in pdl areas are
     ;; always allocated on page boundaries, to simplify this code (make-stack-group enforces
     ;; this constraint).
     ;; M-1 is at the first word of a volatile page.
scavenge-carefully-find-header
        (call-xct-next read-structure-handle)
       ((m-3) q-page-number m-1)
     ;; If <first-header> (M-5) = 0, the structure starts on this page.
        (jump-not-equal-xct-next m-5 a-zero scavenge-carefully-find-header)
       ((m-1) sub m-1 (a-constant 400))
        ((m-1) add m-1 (a-constant 400))		   ;Undo superfluous subtract.

     ;; Now compute the size and current boxed/unboxed boundary of the object.
     ;; M-1 points to the header of a structure that contains volatile pointers.
        (call-xct-next structure-info)
       ((m-t) q-pointer m-1)
        ((a-scavenge-object) q-pointer m-1)
        ((a-scavenge-block-bound) add m-1 a-3)
        ((a-scavenge-next-object) add a-scavenge-block-bound m-4)

	((m-tem) dpb m-zero q-all-but-pointer-within-page a-scavenge-next-object)
	(call-not-equal m-tem a-zero illop)	;pdl not allocated on block boundary.
			;This can also be caused if PDL is forwarded, but BODY-FORWARD
			;Qs somehow get stored in.

     ;; Clear volatility of every page in the object (including unboxed words) to zero.
     ;; SCAVENGE-BLOCK will raise the volatilities to their correct values.
scavenge-carefully-update-volatilities
        (jump-greater-or-equal m-1 a-scavenge-next-object scavenge-object-carefully)
        ((a-gc-trap-vma) m-1)
        (call-xct-next update-page-volatility)
       ((a-gc-trap-md-volatility) m-zero)
        (jump-xct-next scavenge-carefully-update-volatilities)
       ((m-1) add m-1 (a-constant 400))

scavenge-object-carefully
     ;; If we suspend scavenging during this invocation of scavenge-block, we need to
     ;; recompute the size of the object before we resume, because the boxed/unboxed
     ;; boundary may have changed (the pdl-pointer may have changed).  This is the
     ;; raison d'etre of "careful scavenging".
        ((a-scavenge-state) (a-constant 3))
        ((a-scavenge-object-bound) m-minus-one)
        (call-xct-next scavenge-block)
       ((m-1) a-scavenge-object)
        (jump-xct-next scavenge-region-carefully)
       ((m-1) a-scavenge-next-object)

;;; Scavenge block.

scavenge-block-next-object
        ((m-1) a-scavenge-next-object)
        ((a-scavenge-object-bound) m-minus-one)
scavenge-block
scavenge-block-loop
     ;; It's important to test for block boundary before object boundary.  Also, note
     ;; that skipping over unboxed words can take M-1 past block boundary, so test for
     ;; greater-or-equal.
        (popj-greater-or-equal m-1 a-scavenge-block-bound)
        (jump-equal m-1 a-scavenge-object-bound scavenge-block-next-object)
       	((vma-start-read) m-1)
        (check-page-read)
        ((a-scavenge-work) add m-minus-one a-scavenge-work)
        ((m-1) add m-1 (a-constant 1))
        (dispatch q-data-type d-scavenge-word md)
        (dispatch transport-scav md)
        ((vma-start-write) vma)
        (check-page-write-force)
	(gc-write-test-volatility)
	(jump-equal a-scavenge-idle-flag a-v-true scavenge-maybe-suspend-idle-scavenging)
        (jump-less-than m-zero a-scavenge-work scavenge-block-loop)

     ;; Completed scavenge work quantum -- suspend scavenge-block in a resumable way.
        (jump-xct-next suspend-scavenge)
       ((a-scavenge-block-return-pc) micro-stack-data-pop)

scavenge-maybe-suspend-idle-scavenging
     ;; Suspend if we waited for the disk at all.
        (jump-equal a-scavenger-start-disk-time a-disk-wait-time scavenge-block-loop)
	((a-scavenge-work) a-zero)
	(jump-xct-next suspend-scavenge)
       ((a-scavenge-block-return-pc) micro-stack-data-pop)

scavenge-block-header
     ;; Quickly check for things that are guaranteed to be boxed -- we can simply return and
     ;; work our way through them.
        ((m-tem) (lisp-byte %%header-type-field) md)
        (popj-equal m-tem (a-constant (eval %header-type-list)))           ;Lists are all boxed.
        (popj-equal m-tem (a-constant (eval %header-type-array-leader)))   ;Leaders are boxed to the header.
        (jump scavenge-block-general-object)

scavenge-block-array-header
     ;; Simply popj for ART-Q arrays as above, since they're always all boxed.
        ((m-tem) (lisp-byte %%array-type-field) md)
        (popj-equal m-tem (a-constant (eval (lsh art-q array-type-shift))))
     ;; Fall through for general arrays.

scavenge-block-general-object
     ;; Back up one since we pre-incremented in the loop.
        ((m-1) add m-minus-one a-1)
        (call-xct-next structure-info)
       ((m-t) q-pointer m-1)
     ;; Restart reference, since VMA/MD probably lost in STRUCTURE-INFO.
        ((vma-start-read) m-1)
        (check-page-read)
     ;; If there are no unboxed words, can go until block bound or until next header.
     ;; Remember to increment M-1 before returning.
        (popj-equal-xct-next m-4 a-zero)
       ((m-1) add m-1 (a-constant 1))

     ;; Boxed/unboxed boundary := M-1 + Boxed-words - 1.  -1 is because we just incremented.
        ((m-tem) add m-1 a-3)
        (popj-after-next
          (a-scavenge-object-bound q-r) add m-minus-one a-tem)
       ((a-scavenge-next-object) add q-r a-4)
        
(locality d-mem)
(start-dispatch 5 0)
d-scavenge-word
	(n-bit scavenge-block-loop)			       ;trap (immediate) (allowed in PDLs and SGs)
	(p-bit r-bit)				       ;null
	(n-bit scavenge-block-loop)			       ;unreconciled.  
	(p-bit r-bit)				       ;symbol
	(p-bit r-bit)				       ;symbol-header (all boxed)
	(n-bit scavenge-block-loop)			       ;fix (immediate)
	(p-bit r-bit)				       ;extended-number
	(p-bit n-bit scavenge-block-header)	       ;header
	(p-bit r-bit)				       ;gc-forward
	(p-bit r-bit)				       ;external-value-cell-pointer
	(p-bit r-bit)				       ;one-q-forward
	(p-bit r-bit)				       ;header-forward
	(p-bit r-bit)				       ;body-forward
	(p-bit r-bit)				       ;locative
	(p-bit r-bit)				       ;list
	(n-bit scavenge-block-loop)			       ;u code entry (immediate)
	(p-bit r-bit)				       ;fef
	(p-bit r-bit)				       ;array-pointer
	(p-bit n-bit scavenge-block-array-header)      ;array-header
	(p-bit r-bit)				       ;stack-group
	(p-bit r-bit)				       ;closure
	(n-bit scavenge-block-loop)			       ;small-flonum (immediate)
	(p-bit r-bit)				       ;select-method
	(p-bit r-bit)				       ;instance
	(p-bit r-bit)				       ;instance-header (all boxed)
	(p-bit r-bit)				       ;entity
	(p-bit r-bit)				       ;stack-closure
	(n-bit scavenge-block-loop)			       ;self-ref-pointer (immediate)
	(n-bit scavenge-block-loop)			       ;character (immediate)
        (p-bit r-bit)				       ;rplacd-forward
        (p-bit n-bit illop)			       ;36
        (n-bit scavenge-block-loop)			       ;trap (immediate) (allowed in PDLs and SGs)
(end-dispatch)
(locality i-mem)

;;;

finish-scavenge
        (jump-not-equal m-minus-one a-scavenge-queue-pointer finish-scavenge-not-quite-done)
        ((a-scavenge-state) m-zero)
        (jump-xct-next scavenge-restore)
       ((a-gc-flip-ready) a-v-true)

finish-scavenge-not-quite-done
     ;; All regions seem scavenged, but there are still objects on the scavenge queue.
     ;; Run the queue to completion (won't take long), then loop through all the regions
     ;; again, just to make sure.
        (call-not-equal-xct-next m-minus-one a-scavenge-queue-pointer run-scavenge-queue)
       ((a-scavenge-queue-work) dpb m-minus-one q-pointer a-zero)
        (jump scavenge-regions)

;;;

(begin-comment) Zwei Lossage (end-comment)

load-region-scavenge-parameters
        ((m-k) a-scavenge-region)
        ((vma-start-read) add m-k a-v-region-origin)
        (illop-if-page-fault)
        ((a-scavenge-region-origin) q-pointer md)
        ((vma-start-read) add m-k a-v-region-gc-pointer)
        (check-page-read)
        ((m-1) output-selector-mask-25 add md a-scavenge-region-origin)
load-scavenge-region-free-pointer    
   ;must be transparent to q-r.  This is OK since no page faults possible
        (popj-equal-xct-next m-k a-copy-cons-cache-region)
       ((a-scavenge-region-free-pointer) dpb m-zero q-all-but-pointer a-copy-cons-cache-free-pointer)
        (popj-equal-xct-next m-k a-active-cons-cache-region)
       ((a-scavenge-region-free-pointer) dpb m-zero q-all-but-pointer a-active-cons-cache-free-pointer)
        ((vma-start-read) add m-k a-v-region-free-pointer)
        (illop-if-page-fault)
        (popj-after-next)
       ((a-scavenge-region-free-pointer) output-selector-mask-25 add md a-scavenge-region-origin)

;;; This is an interesting hack.  During all the various loops in the scavenger, we're continually
;;; checking M-1 (the scavenge pointer) against a-scavenge-region-free-pointer to see if we're done.
;;; Since there is often consing going on in regions (particularly copy regions!) as we scavenge
;;; them, the region-free-pointer is moving, but we don't notice it cause we only set up
;;; a-scavenge-region-free-pointer at the beginning.  This can cause the scavenger to move on to other
;;; regions before truly finishing one, which is OK since we will come back to it, but it is slow.
;;; To remedy this, test for the end of a region with:
;;;    (call-greater-or-equal m-1 a-scavenge-region-free-pointer scavenge-check-region-free-pointer)
;;; which will update a-scavenge-region-free-pointer based on the latest information.  The interesting
;;; part is that it only returns to the caller if there are more words to be scavenged in this region.
;;; Otherwise, it jumps to SCAVENGE-NEXT-REGION, fixing up the microstack appropriately.  Nifty, eh?

scavenge-check-region-free-pointer
        (call-xct-next load-scavenge-region-free-pointer)
       ((m-k) a-scavenge-region)
        (popj-less-than m-1 a-scavenge-region-free-pointer)
        (jump-xct-next scavenge-next-region)
       ((m-garbage) micro-stack-data-pop)

store-region-gc-pointer
        ((vma) a-scavenge-region)
        ((vma) add vma a-v-region-gc-pointer)
        ((md) q-pointer m-1 (a-constant (byte-value q-data-type dtp-fix)))
        (popj-after-next
          (md-start-write) sub md a-scavenge-region-origin)
       (check-page-write-no-interrupt)

(locality a-mem)
a-scavenge-save-a (0)
a-scavenge-save-b (0)
a-scavenge-save-k (0)
a-scavenge-save-t (0)
a-scavenge-save-1 (0)
a-scavenge-save-2 (0)
a-scavenge-save-3 (0)
a-scavenge-save-4 (0)
a-scavenge-save-5 (0)
a-scavenge-save-6 (0)
(locality i-mem)

scavenge-save
#-lambda(begin-comment)
        ((a-scavenger-start-time) stat-counter-aux)
        ((a-scavenger-start-disk-time) a-disk-wait-time)
        ((a-scavenger-transporter-start-time) a-transporter-time)
        ((a-scavenger-transporter-start-disk-time) a-transporter-disk-time)
#-lambda(end-comment)
        (call-xct-next turn-on-scavenger-run-light)
       ((m-scavenge-flag) dpb m-minus-one a-flags)
        ((a-scavenge-save-a) m-a)
        ((a-scavenge-save-b) m-b)
        ((a-scavenge-save-k) m-k)
        ((a-scavenge-save-t) m-t)
        ((a-scavenge-save-1) m-1)
        ((a-scavenge-save-2) m-2)
        ((a-scavenge-save-3) m-3)
        ((a-scavenge-save-4) m-4)
        (popj-after-next
          (a-scavenge-save-5) m-5)
       ((a-scavenge-save-6) m-6)

suspend-scavenge
        (call store-region-gc-pointer)
scavenge-restore
#-lambda(begin-comment)
        ((m-tem) sub stat-counter-aux a-scavenger-start-time)
     ;; Subtract out time spent in transporter.
        ((m-tem) add m-tem a-scavenger-transporter-start-time)
        ((m-tem) sub m-tem a-transporter-time)
        ((a-scavenger-time) add m-tem a-scavenger-time)
        ((m-tem) a-disk-wait-time)
        ((m-tem) sub m-tem a-scavenger-start-disk-time)
     ;; Subtract out time spent in transporter.
        ((m-tem) add m-tem a-scavenger-transporter-start-disk-time)
        ((m-tem) sub m-tem a-transporter-disk-time)
        ((a-scavenger-disk-time) add m-tem a-scavenger-disk-time)
#-lambda(end-comment)
        ((m-scavenge-flag) dpb m-zero a-flags)
        (call turn-off-scavenger-run-light)
        ((m-a) a-scavenge-save-a)
        ((m-b) a-scavenge-save-b)
        ((m-k) a-scavenge-save-k)
        ((m-t) a-scavenge-save-t)
        ((m-1) a-scavenge-save-1)
        ((m-2) a-scavenge-save-2)
        ((m-3) a-scavenge-save-3)
        ((m-4) a-scavenge-save-4)
        (popj-after-next
          (m-5) a-scavenge-save-5)
       ((m-6) a-scavenge-save-6)

turn-on-scavenger-run-light
        ((vma) a-disk-run-light)
        ((vma-start-read) sub vma (a-constant 2))
        (check-page-read-map-reload-only)
        ((m-tem) md)
        ((md-start-write) dpb m-minus-one (byte 20 0) a-tem)
        (check-page-write-map-reload-only)
     ;; Turn off user run light.
        ((vma) add vma (a-constant 4))
        (popj-after-next
          (md-start-write) m-zero)
       (check-page-write-map-reload-only)

turn-off-scavenger-run-light
        ((vma) a-disk-run-light)
        ((md) m-zero)
        ((vma-start-write) sub vma (a-constant 2))
        (check-page-write-map-reload-only)
     ;; Turn on user run light.
        ((vma) add vma (a-constant 4))
        (popj-after-next
          (md-start-write) m-minus-one)
       (check-page-write-map-reload-only)

(begin-comment) Zwei Lossage (end-comment)

;;; Scavenge queue.

;;; The scavenge queue is a small (1024 word) area of memory managed in a stack-like fashion
;;; to do approximately depth-first copying of objects in the transporter (and thus the
;;; scavenger).  Each entry on the queue is one word, consisting of a 25-bit address and a
;;; 7-bit word count.  The address is the address of the next word to be scavenged, the count
;;; is the remaining words in the entry.  When every word is looked at, the entry on the queue
;;; is updated (looking at a word can cause more objects to appear on the queue, so this whole
;;; process must be very reentrant) by incrementing the address and decrementing the word
;;; count.  When the count for an object gets to zero, the object is popped off the queue, and
;;; then that word is looked at (sort of tail-recursively).

;;; Yes, this code is pretty simple.  However, there are some non-trivial interactions with
;;; TRANS-OLD-COPY that you have to be careful about.

(locality a-mem)
a-scavenge-queue-pointer (-1)  ;Points to current entry.  Pushing on the queue pre-increments.
a-scavenge-queue-active (0)    ;Communication with transporter.
a-scavenge-queue-work (0)      ;Number of units remaining in this invocation.
(locality i-mem)

;;; Called at the end of TRANS-OLD-COPY to put the copied object on the scavenge-queue and
;;; to do some scavenge-queue work.  This can use no accumulators.
transport-run-scavenge-queue

   ;If the object is bigger than 77 q's, we put only the first 77 on the queue.
   ;The scavenge queue is not so important as to waste time figuring out how to
   ;improve locality of large objects.
        ((m-tem) a-transport-boxed-size)
        (jump-less-than m-tem (a-constant 77) transport-run-scavenge-queue-push-object)
        ((m-tem) (a-constant 77))

transport-run-scavenge-queue-push-object
        ((md) dpb m-tem (byte 6 31) a-transport-new-object-base)       ;Put count into high bits.
        ((m-tem) m+a+1 m-zero a-scavenge-queue-pointer)		       ;Compute new pointer.
        (popj-greater-or-equal m-tem a-scavenge-queue-maximum-depth)   ;Queue full, punt.
        ((a-scavenge-queue-pointer) m-tem)			       ;Save new pointer.
        ((vma-start-write) add m-tem a-v-scavenge-queue)	       ;Save entry.
        (check-page-write)
        (popj-not-equal m-zero a-scavenge-queue-active)		       ;Not reentrant from here on.
        ((pdl-push) a-transport-new-object)			       ;Save these for restarting trap.
        ((pdl-push) a-trans-vma)
        (call-xct-next run-scavenge-queue)
       ((a-scavenge-queue-work) a-transporter-scavenge-queue-work-quantum)
        (popj-after-next
          (a-trans-vma) pdl-pop)
       ((a-transport-new-object) pdl-pop)

;;; Set A-SCAVENGE-COUNT to the maximum number of words to look at before calling this.  When
;;; this returns, it will either be zero (there may still be entries on the queue) or the
;;; initial value minus the number of words scanned (the queue was exhausted).
run-scavenge-queue
        ((a-scavenge-queue-active) (a-constant 1))
scavenge-queue-loop
        ((m-tem) a-scavenge-queue-pointer)
        (jump-less-than m-tem a-zero scavenge-queue-exit)      ;Queue empty, punt.
        ((vma-start-read) add m-tem a-v-scavenge-queue)
        (check-page-read)
        ((m-tem1) q-all-but-pointer md)		               ;Word count for this object.
        (jump-less-or-equal-xct-next m-tem1 (a-constant 1) pop-scavenge-queue)
       ((pdl-push) q-pointer md)		               ;Location to be checked, popped below.
        ((m-tem1) sub m-tem1 (a-constant 1))
        ((m-tem) output-selector-mask-25 add md (a-constant 1))
        ((md-start-write) dpb m-tem1 q-all-but-pointer a-tem)  ;Update queue before transport.
        (check-page-write)
scavenge-queue-transport
       	((vma-start-read) pdl-pop)
        (check-page-read)
        ((a-scavenge-queue-work) add m-minus-one a-scavenge-queue-work)
        (dispatch transport-scav md)		               ;This might push another object.
        (jump-less-or-equal m-zero a-scavenge-queue-work scavenge-queue-loop)

     ;; Fall through when scavenge-queue work gets to zero.
scavenge-queue-exit
        (popj-after-next)
       ((a-scavenge-queue-active) m-zero)

pop-scavenge-queue
        (jump-xct-next scavenge-queue-transport)
       ((a-scavenge-queue-pointer) add m-minus-one a-scavenge-queue-pointer)


;;; Scanning on swap-out.

;;; All reference volatilities, if left to their own devices, will rise monotonically to
;;; most-volatile and stay there, negating all the benefit of the scheme.  To prevent this from
;;; happening, pages are scanned at various times to determine their correct volatility -- the
;;; volatility of the most-volatile pointer on the page.
;;;
;;; Note that there are two basic ways that more-volatile pointers can be removed from a page.
;;; Lisp program activity can overwrite volatile pointers (I think this is pretty rare).  More
;;; importantly, when the scavenger scans a page that has pointers of volatility N, by definition
;;; when the scavenger is done the maximum possible volatility is N-1.  This principle also
;;; applies in a probabilistic way to the localizer.
;;;
;;; The effect of letting the reference volatility of a page rise higher than it needs to be
;;; is that at some point the scavenger will examine it unnecessarily.  Examining a page that
;;; already resides in primary memory is not too painful (more on that later), but if the page
;;; has been swapped out to the disk, the overhead of swapping it back in, only to find out that
;;; it wasn't really needed, is unacceptable.  Therefore, we try to ensure that non-resident pages
;;; always have their correct volatility.
;;;
;;; The best way to implement this is to scan every modified page as it is being written back to
;;; the disk in preparation for reuse of a page frame.  There is a problem with this: we (theoretically)
;;; can not scan a page without the aid of the structure handles to decipher the object boundaries
;;; on a page.  Unfortunately, the structure handles are not and can not be wired; since the scanning
;;; occurs deep inside the page fault handler, accessing the structure handles would require
;;; arbitrary levels of recursion in the hard-fault handler.
;;;
;;; Without the aid of the structure handles, we cannot avoid looking at untagged storage.  It
;;; turns out that this is actually acceptable -- as long as we're not depending on the actual
;;; meaning of words of memory, we can scan through looking for volatile "pointers" without danger.
;;; Of course, the results are only probabilistic.  However, measurements indicate that we get the
;;; correct answer between 98-99% of the time, which is perfectly reasonable.
;;;
;;; The overall effect of this is to reduce the disk traffic required to scavenge levels 1, 2 and 3
;;; if the pages have had a chance to migrate to the disk.  In practice, almost all storage involved in 
;;; level 3 flips is in core anyway, so this scheme really only affects level 1 and 2 flips.  The
;;; overall gain appears to be a 2x - 3x reduction in paging during level 1 and 2 GCs.
;;;
;;; I think it is moderately important to try to keep the volatility of resident pages correct.
;;; Moon thinks it's unnecessary (he says the 3600 has scanning hardware to scan pages in about
;;; 80 microseconds).  The Lambda, however, takes about 500 microseconds to scavenge a page.
;;; Fortunately, a small amount of overhead in the scavenger (setting the volatility of a page
;;; to zero before scanning, then reading and writing every word to take transport and volatility
;;; traps) can guarantee that the page will have the correct volatility.  I think this small overhead
;;; (figure about 20% of the cost of scavenging a page) is worth the effort -- it prevents pages
;;; from being needlessly scavenged 2, 3, 4... times.

;;; VOLATILITY-SCAN-PAGE is called for every page written to the disk by DISK-SWAP-HANDLER.  It
;;; runs in parallel with the disk (primarily with the seek, so I don't think bus bandwidth is
;;; a problem).  It may take map faults and pdl-buffer faults, but obviously can't take any
;;; hard faults.  We do a GC-WRITE-TEST on every word on the page, but the only action we can
;;; take as a result is to update the volatility.  If an untagged word happens to have a pointer
;;; data-type and a pointer field that points to volatile storage, then we will get a too-high
;;; answer.  This doesn't happen too often, but just to help limit the lossage, we don't let the
;;; final volatility rise above the initial volatility.

;;; Post-mortem:
;;; There were some initial problems with this (it made pages be modified even after they
;;; were written to the disk, it changed pages' swap-status to normal) that caused performance
;;; to degrade dramatically when I first installed this.  After fixing all the (known)
;;; problems with it, we ran some benchmarks which showed that there was really no effect
;;; on performance.  I don't know why, but for now I'm deleting it.

;;; Page (virtual-address) in vma.
;volatility-scan-page
;     ;; If bit 4 of disk switches is 1, scanning is disabled.
;        ((q-r) a-disk-switches)
;        (popj-if-bit-set (byte 1 4) q-r)
;        ((pdl-push) m-1)
;        ((pdl-push) m-t)
;     ;; Save virtual page address for volatility update below.
;        ((a-gc-trap-vma) vma)
;     ;; Read current page volatility and save on stack.
;        (call-xct-next read-page-volatility)
;       ((m-lam) q-page-number vma)
;        (jump-equal m-tem a-zero volatility-scan-page-abort)
;        ((pdl-push) m-tem)
;     ;; Set reference volatility of this page down to zero.
;        (call-xct-next update-page-volatility)
;       ((a-gc-trap-md-volatility) m-zero)
;     ;; M-1 gets first word of page, VMA gets first word of next page.  Count VMA down
;     ;; to M-1, GC-WRITE-TESTING every word.  Read first word to map page in, then change
;     ;; map access to read/write.
;        (call-xct-next search-page-hash-table)
;       ((m-t) a-gc-trap-vma)
;        ((pdl-push) vma)
;        ((pdl-push) md)
;        ((vma-start-read m-1) a-gc-trap-vma)
;        (check-page-read)
;        ((md) m-1)
;        (no-op)
;	((#+lambda l2-map-control
;	  #+exp vma-write-l2-map-control
;	  m-tem) ior l2-map-control	;Force read/write access
;		(a-constant (byte-value map2c-access-code 3)))
;        ((vma) add m-1 (a-constant 400))
;volatility-scan-page-loop
;       	((vma-start-read) sub vma (a-constant 1))
;        (illop-if-page-fault)
;        ((vma-start-write) vma)
;        (illop-if-page-fault)
;        (jump-not-equal-xct-next vma a-1 volatility-scan-page-loop)
;       (gc-write-test-volatility)
;        ((md) pdl-pop)
;        ((vma-start-write) pdl-pop)
;        (illop-if-page-fault)
;	((#+lambda l2-map-control
;	  #+exp vma-write-l2-map-control) (a-constant 0))
;     ;; Read current volatility of page.  If current volatility is greater than what it
;     ;; started with, update volatility to old value.  This helps minimize randomness.
;        (call-xct-next read-page-volatility)
;       ((m-lam) q-page-number m-1)
;        ((a-gc-trap-vma) m-1)
;        ((a-gc-trap-md-volatility) pdl-pop)
;        (call-greater-than m-tem a-gc-trap-md-volatility update-page-volatility)
;volatility-scan-page-abort
;        (popj-after-next (m-t) pdl-pop)
;       ((m-1) pdl-pop)

))