(defun scan-user-spaces ()
  (prog ()
     (for s in user-spaces do
        (users-\gcscanstack-helper s))
     (return nil)))
        

(* scan-space is modelled on \GCSCANSTACK in LLSTK. 
   I assume that interrupts are off when its called. *) 

(defun scan-space (space)
 (prog (scan-ptr free-ptr tag arg-ptr nargs)
   (* Run through the entire space, calling \stkref 
      on each pointer. *)
   (setq scan-ptr 
      (locf (fetch (space-header successor) of space)))
   (setq free-ptr 
      (fetch (space-header free) of space))

   (while (ptrgtp free-ptr scan-ptr) do
      (setq tag (fetch (typed-object typetag) of scan-ptr))
      (select tag
        (space-header-tag
          (\stkref (fetch (space-header size) of scan-ptr))
          (\stkref (fetch (space-header hiptr) of scan-ptr))
          (\stkref (fetch (space-header free) of scan-ptr))
          (\stkref 
             (fetch (space-header wordsleft) of scan-ptr)))

        (stack-closure-tag
          (\stkref (fetch (stack-closure skeleton) of scan-ptr))
          (\stkref (fetch (stack-closure env) of scan-ptr))
          (setq scan-ptr 
             (locf (fetch (stack-closure successor) 
                      of scan-ptr))))

        (stack-cont-tag
          (\stkref (fetch (stack-cont pc) of scan-ptr))
          (\stkref (fetch (stack-cont env) of scan-ptr))
          (\stkref (fetch (stack-cont frame) of scan-ptr))
          (\stkref (fetch (stack-cont next) of scan-ptr))
          (\stkref (fetch (stack-cont cont) of scan-ptr))
          (setq scan-ptr 
             (locf (fetch (stack-cont successor) of scan-ptr))))

        (stack-frame-tag
          (setq nargs (fetch (stack-frame nargs) of scan-ptr))
          (setq arg-ptr (locf (fetch (stack-frame proc) 
                                 of scan-ptr)))
          (for i from 1 to (add1 nargs) do
             (\stkref (fetch (cell contents) of arg-ptr))
             (setq arg-ptr 
               (locf (fetch (cell successor) of arg-ptr))))
          (setq scan-ptr arg-ptr))
 
        (progn
          (raid "Extended gcscanstack can't parse space")
          (go exit))))
  exit
    (return nil)))


(defun modified-\gcscanstack ()
   (users-\gcscanstack)
   (original-\gcscanstack))

(defun install-scan-space ()
  (prog ()
    (* Done in such a way as not to kill the user
       too quickly. *)
    (if (or (not (ccodep 'scan-space))
            (not (ccodep 'scan-user-spaces))
            (not (ccodep 'modified-\gcscanstack))) then
        (shouldnt "must compile scan-space et al."))
    (if (null (getd 'original-\gcscanstack)) then
        (putd 'original-\gcscanstack (getd '\gcscanstack)))
    (putd 'users-\gcscanstack (getd 'scan-user-spaces))
    (putd 'users-\gcscanstack-helper (getd 'scan-space))
    (putd '\gcscanstack (getd 'modified-\gcscanstack))))

(defun destall-scan-spaces ()
  (prog ()
    (putd '\gcscanstack (getd 'original-\gcscanstack))
    (return nil)))



(* ***** Generation scavenging garbage collector ******)


(defun gsgc-test1 ()
  (prog (e1 e2 e3 e4 e5)
    (reset-spaces)
    (setq e5 (ncreate-closure 'sk1 nil))
    (setq e4 (ncreate-closure 'sk2 e5))
    (setq e3 (ncreate-closure 'sk3 e4))
    (setq e2 (ncreate-closure 'sk4 e4))
    (setq e1 (ncreate-closure e2 e3))
    (show-spaces)
    (for i from 1 to 3 do
       (setq e1 (gsgc e1))
       (printout nil "Root is " e1 t)
       (show-spaces))
    (show-spaces)))


(defun gsgc (root)
 (prog (new-root w temp) 
   (setq new-root (evacuate root))

   (* Evacuate all objects known to the "outside" world. *)

   (setq w wrap-anchor)
   (while (not (null w)) do
      (replace (nlisp-object uglyaddr) of w with
         (evacuate (fetch (nlisp-object uglyaddr) of w)))
      (setq w (fetch (nlisp-object nextobj) of w)))

   (* Force closure on future-survivor-space. *)
   (scavenge-future-survivor-space)

   (* Reset new-space and past-survivor-space. *)
   (reset-space new-space t)
   (reset-space past-survivor-space t)
   (setq temp past-survivor-space)
   (setq past-survivor-space future-survivor-space)
   (setq future-survivor-space temp)
   (return new-root)))

(defun evacuate (obj)
  (prog (clone)
   (if (not (stack-object? obj)) then (return obj))
   (if (and (not (in-new-space? obj))
            (not (in-past-survivor-space? obj))) then 
       (return obj))
   (if (fetch (gc-object gone) of obj) then
       (return (fetch (gc-object snake) of obj)))
   (setq clone (clone-object obj))
   (uninterruptably
      (replace (gc-object gone) of obj with t)
      (replace (gc-object snake) of obj with clone))
   (return clone)))


(defun clone-object (obj)
 (prog (nw base age)
   (setq age (fetch (typed-object age) of obj))
   (setq nw 
    (select (fetch (typed-object typetag) of obj)
      (stack-closure-tag   words-per-stack-closure)
      (stack-cont-tag      words-per-stack-cont)
      (stack-frame-tag
         (iplus words-per-stack-frame
            (itimes (fetch (stack-frame nargs) of obj)
               words-per-ptr)))
      (shouldnt "can't parse stack")))

   (* No tenuring at present. *)
   (uninterruptably
      (setq base (allocate-from future-survivor-space nw))
      (for i from 0 to (sub1 nw) do
         (\putbase base i (\getbase obj i))))
   (replace (typed-object age) of base with 
      (logand 377q (add1 age)))
   (return base)))

(defun scavenge-future-survivor-space ()
 (prog (scan-ptr arg-ptr hiloc)
   (setq scan-ptr 
      (locf (fetch (space-header successor) of
                future-survivor-space)))
   (while (ptrgtp 
             (fetch (space-header free) 
                of future-survivor-space)
             scan-ptr) do
     (select (fetch (typed-object typetag) of scan-ptr)
       (stack-closure-tag 
          (replace (stack-closure env) of scan-ptr with
             (evacuate (fetch (stack-closure env) of scan-ptr))) 
          (replace (stack-closure skeleton) of scan-ptr with
             (evacuate 
                (fetch (stack-closure skeleton) of scan-ptr)))
          (setq scan-ptr 
             (locf 
                (fetch (stack-closure successor) of scan-ptr))))

      (stack-cont-tag
          (replace (stack-cont pc) of scan-ptr with
             (evacuate (fetch (stack-cont pc) of scan-ptr)))
          (replace (stack-cont env) of scan-ptr with
             (evacuate (fetch (stack-cont env) of scan-ptr)))
          (replace (stack-cont frame) of scan-ptr with
             (evacuate (fetch (stack-cont frame) of scan-ptr)))
          (replace (stack-cont next) of scan-ptr with
             (evacuate (fetch (stack-cont next) of scan-ptr)))
          (replace (stack-cont cont) of scan-ptr with
             (evacuate (fetch (stack-cont cont) of scan-ptr)))
          (setq scan-ptr 
             (locf (fetch (stack-cont successor) of scan-ptr))))

      (stack-frame-tag
          (replace (stack-frame proc) of scan-ptr with
             (evacuate (fetch (stack-frame proc) of scan-ptr)))
          (setq arg-ptr 
             (locf (fetch (stack-frame arg1) of scan-ptr)))
          (for i from 1 to (fetch (stack-frame nargs) of scan-ptr) do
             (replace (cell contents) of arg-ptr with
                (evacuate (fetch (cell contents) of arg-ptr)))
             (setq arg-ptr 
               (locf (fetch (cell successor) of arg-ptr))))
          (setq scan-ptr arg-ptr))
 
      (shouldnt "can't parse stack")))
   (return nil)))