(* Low level stack tricks. *)

(constants space-header-tag stack-frame-tag 
    stack-cont-tag stack-closure-tag
    words-per-space-header words-per-stack-frame 
    words-per-stack-cont words-per-stack-closure 
    words-per-ptr)

(* Note that the SUCCESSOR field in not part of the following 
   records; its just there to allow the following object 
   to be created. *)

(blockrecord space-header
   ((typetag byte)
    (gone flag)
    (spare1 bits 7)
    (spare2 byte)
    (age byte)
    (free fullxpointer)
    (size fullxpointer)
    (wordsleft fullxpointer)
    (hiptr fullxpointer)
    (successor fullxpointer)))

(blockrecord stack-frame
   ((typetag byte)
    (gone flag)
    (objectified flag)
    (embedded flag)
    (spare1 bits 5)
    (nargs byte)
    (age byte)
    (proc fullxpointer)
    (arg1 fullxpointer)
    (arg2 fullxpointer)
    (arg3 fullxpointer)))


(blockrecord stack-cont
   ((typetag byte)
    (gone flag)
    (spare1 bits 7)
    (spare2 byte)
    (age byte)
    (pc fullxpointer)
    (env fullxpointer)
    (frame fullxpointer)
    (next fullxpointer)
    (cont fullxpointer)
    (successor fullxpointer)))

(blockrecord stack-closure
   ((typetag byte)
    (gone flag)
    (spare1 bits 7)
    (spare2 byte)
    (age byte)
    (skeleton fullxpointer)
    (env fullxpointer)
    (successor fullxpointer)))

(blockrecord cell 
   ((contents fullxpointer)
    (successor fullxpointer)))

(blockrecord typed-object 
   ((typetag byte)
    (gone flag)
    (spare1 bits 7)
    (spare2 byte)
    (age byte)))

(blockrecord gc-object
  ((typetag byte)
   (gone flag)
   (spare1 bits 7)
   (spare2 byte)
   (age byte)
   (snake fullxpointer)))

(globalvars new-space old-space
   future-survivor-space past-survivor-space
   wrap-anchor user-spaces)


(defun initialise-tags-etc ()
 (prog ()
   (setq stack-frame-tag 1)
   (setq stack-cont-tag 2)
   (setq stack-closure-tag 3)
   (setq space-header-tag 4)
   (setq words-per-space-header 10)
   (setq words-per-stack-cont 12)
   (setq words-per-stack-closure 6)
   (setq words-per-stack-frame 4)
   (setq words-per-ptr 2)))

(initialise-tags-etc)  (* They are all constants. *)


(* Strictly speaking, not every pointer to into arrayspace is
   one of ours.  This may have to be changed later. *)
 
(defmacro stack-object? (x)
   (type? arrayblock x))
 
(defun create-space (npointers)
 (prog (space space-size)
   (setq space-size (itimes npointers words-per-ptr))
   (setq space (\allocblock space-size))
   (for i from 0 to (sub1 space-size) do
      (\putbase space i 0))
   (replace (space-header typetag) of space with 
      space-header-tag)
   (replace (space-header size) of space with 
      space-size)
   (replace (space-header hiptr) of space with 
      (\addbase space (idifference space-size words-per-ptr)))
   (replace (space-header free) of space with 
      (locf (fetch (space-header successor) of space)))
   (replace (space-header wordsleft) of space with 
      (idifference space-size words-per-space-header))
   (return space)))

(defun create-spaces (nold nnew nsurvivors)
 (prog ()
    (setq wrap-anchor nil)
    (setq old-space (create-space nold))
    (setq new-space (create-space nnew))
    (setq future-survivor-space (create-space nsurvivors))
    (setq past-survivor-space (create-space nsurvivors))
    (apply 'addtovar (list 'user-spaces old-space new-space 
        future-survivor-space past-survivor-space))
    (return nil)))

(defun reset-space (space dont-zero)
  (prog (space-size)
   (setq space-size (fetch (space-header size) of space))
   (if dont-zero then
      (\putbase space 0 0)
      (\putbase space 1 0)
    else
      (for i from 0 to (sub1 space-size) do
         (\putbase space i 0)))
   (replace (space-header typetag) of space with 
      space-header-tag)
   (replace (space-header size) of space with 
      space-size)
   (replace (space-header hiptr) of space with 
      (\addbase space (idifference space-size words-per-ptr)))
   (replace (space-header free) of space with 
      (locf (fetch (space-header successor) of space)))
   (replace (space-header wordsleft) of space with 
      (idifference space-size words-per-space-header))
   (return space)))

(defun reset-spaces ()
  (prog ()
     (setq wrap-anchor nil)
     (for s in user-spaces do (reset-space s nil))
     (return user-spaces)))

  
(defun parse-space (space fn)
 (prog (scan-ptr free-ptr tag age nw)
   (* Run through the entire space, calling fn on each object. *)
   (setq free-ptr (fetch (space-header free) of space))
   (setq scan-ptr space)
   (while (ptrgtp free-ptr scan-ptr) do
      (setq tag (fetch (typed-object typetag) of scan-ptr))
      (setq age (fetch (typed-object age) of scan-ptr))
      (select tag
        (space-header-tag 
          (apply* fn tag scan-ptr words-per-space-header age)
          (setq scan-ptr 
             (locf (fetch (space-header successor) of scan-ptr))))
        (stack-closure-tag
          (apply* fn tag scan-ptr words-per-stack-closure age)
          (setq scan-ptr 
             (locf (fetch (stack-closure successor) of scan-ptr))))

        (stack-cont-tag
          (apply* fn tag scan-ptr words-per-stack-cont age)
          (setq scan-ptr 
             (locf (fetch (stack-cont successor) of scan-ptr))))

        (stack-frame-tag
          (setq nw
            (iplus words-per-stack-frame
              (itimes words-per-ptr  
                (fetch (stack-frame nargs) of scan-ptr))))
          (apply* fn tag scan-ptr nw age)
          (setq scan-ptr (\addbase scan-ptr nw))) 
 
        (shouldnt "can't parse stack")))
   (return nil)))


(defun in-space? (space ptr)
   (and (ptrgtp ptr space) 
        (not (ptrgtp ptr (fetch (space-header hiptr) of space)))))
   
(defmacro in-new-space? (x) 
   (in-space? new-space x))

(defmacro in-past-survivor-space? (x)
   (in-space? past-survivor-space x))

(defmacro in-future-survivor-space? (x)
   (in-space? future-survivor-space x))

(defmacro in-old-space? (x)
   (in-space? old-space x))

(defmacro allocate-from (space xnwords)
  (prog (xfree xleft)
   (setq xfree (fetch (space-header free) of space))
   (setq xleft (fetch (space-header wordsleft) of space))
   (if (ilessp xleft xnwords) then
       (shouldnt "out of space"))
   (replace (space-header free) of space with
      (\addbase xfree xnwords))
   (replace (space-header wordsleft) of space with
      (idifference xleft xnwords))
   (return xfree)))

(defmacro ncreate-cont (xpc xenv xframe xnext xcont)
 (uninterruptably
  (prog (xnew-cont)
   (setq xnew-cont (allocate-from new-space words-per-stack-cont))
   (putbase xnew-cont 0 0)
   (putbase xnew-cont 1 0)
   (replace (stack-cont typetag) of xnew-cont with stack-cont-tag)
   (replace (stack-cont pc) of xnew-cont with xpc)
   (replace (stack-cont env) of xnew-cont with xenv)
   (replace (stack-cont frame) of xnew-cont with xframe)
   (replace (stack-cont next) of xnew-cont with xnext)
   (replace (stack-cont cont) of xnew-cont with xcont)
   (return xnew-cont))))

(defmacro ncreate-closure (xskeleton xenv)
 (uninterruptably
  (prog (xnew-closure)
   (setq xnew-closure 
     (allocate-from new-space words-per-stack-closure))
   (putbase xnew-closure 0 0)
   (putbase xnew-closure 1 0)
   (replace (stack-closure typetag) of xnew-closure with
     stack-closure-tag)
   (replace (stack-closure skeleton) of xnew-closure with xskeleton)
   (replace (stack-closure env) of xnew-closure with xenv)
   (return xnew-closure))))

(defmacro stack-closure? (x)
   (and (stack-object? x)
        (eq stack-closure-tag
            (fetch (typed-object typetag) of x))))

(defmacro ncreate-frame (xnargs xembedded xobjectified)
 (uninterruptably
  (prog (xnew-frame xarg-ptr)
   (setq xnew-frame 
     (allocate-from new-space 
       (iplus words-per-stack-frame 
          (itimes xnargs words-per-ptr))))
   (putbase xnew-frame 0 0)
   (putbase xnew-frame 1 0)
   (replace (stack-frame typetag) of xnew-frame with stack-frame-tag)
   (replace (stack-frame nargs) of xnew-frame with xnargs)
   (replace (stack-frame embedded) of xnew-frame with xembedded)
   (replace (stack-frame objectified) of xnew-frame with xobjectified)
   (replace (stack-frame proc) of xnew-frame with 0)
   (setq xarg-ptr (locf (fetch (stack-frame arg1) of xnew-frame)))
   (for i from 1 to xnargs do
      (replace (cell contents) of xarg-ptr with i)
      (setq xarg-ptr (locf (fetch (cell successor) of xarg-ptr))))
   (return xnew-frame))))

(datatype nlisp-object (uglyaddr nextobj))

(defmacro wrap (x)
  (setq wrap-anchor 
     (create nlisp-object 
            uglyaddr _ x
            nextobj _ wrap-anchor)))


(defmacro unwrap (x)
   (fetch (nlisp-object uglyaddr) of x))

(defmacro closure? (x)
  (and (type? nlisp-object x)
       (stack-closure? (unwrap x))))

(defun show-spaces ()
  (prog ()
    (printout nil "< < < N E W   S P A C E > > >" t)    
    (parse-space new-space (function print-object))
    (printout nil "< < < P A S T   S U R V I V O R S > > >" t)
    (parse-space past-survivor-space (function print-object))
    (printout nil "< < < F U T U R E   S U R V I V O R S > > >" t)
    (parse-space future-survivor-space (function print-object))
    (printout nil "< < < O L D   S P A C E > > >" t)
    (parse-space old-space (function print-object))
    (return nil)))

(defun show-space (space)
   (parse-space space (function print-object)))

(defun print-object (tag obj nwords age)
  (prog (nargs arg-ptr)
    (printout nil "Object " 
       .I6.8.t (\hiloc obj) "," .I6.8.t (\loloc obj)
       " (age " age ")")
    (if (fetch (typed-object gone) of obj) then
        (printout nil " [Gone]"))
    (select tag
      (space-header-tag 
         (printout nil " is a header block." t)
         (printout nil "  size: " 
            (fetch (space-header size) of obj) t)
         (printout nil "  free: " 
            (fetch (space-header free) of obj) t)
         (printout nil "  wordsleft: " 
            (fetch (space-header wordsleft) of obj) t)
         (printout nil "  hiptr: " 
            (fetch (space-header hiptr) of obj) t))

      (stack-closure-tag 
         (printout nil " is a closure." t)
         (printout nil "  skeleton: " 
            (fetch (stack-closure skeleton) of obj) t)
         (printout nil "  env: " 
            (fetch (stack-closure env) of obj) t))

      (stack-cont-tag 
         (printout nil " is a continuation." t)
         (printout nil "  pc: " 
            (fetch (stack-cont pc) of obj) t)
         (printout nil "  env: " 
            (fetch (stack-cont env) of obj) t)
         (printout nil "  frame: " 
            (fetch (stack-cont frame) of obj) t)
         (printout nil "  next: " 
            (fetch (stack-cont next) of obj) t)
         (printout nil "  cont: " 
            (fetch (stack-cont cont) of obj) t))
            
      (stack-frame-tag 
         (setq nargs (fetch (stack-frame nargs) of obj))
         (printout nil " is a frame, nargs: " nargs)
         (printout nil " emb: " 
            (fetch (stack-frame embedded) of obj))
         (printout nil " obj: " 
            (fetch (stack-frame objectified) of obj) t)
         (printout nil "  proc: " 
            (fetch (stack-frame proc) of obj) t)
         (setq arg-ptr (locf (fetch (stack-frame arg1) of obj)))
         (for i from 1 to nargs do
            (printout nil "  arg" i ": " 
               (fetch (cell contents) of arg-ptr) t)
            (setq arg-ptr (locf (fetch (cell successor) of arg-ptr)))) )

       (shouldnt "Unknown tag"))))


STOP