(* 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