;;; -*- Lisp -*-
;;;
;;; Storage purifier for Spice Lisp.
;;; Written by Skef Wholey.
;;;
;;; The function Purify, defined herein, puts as much of the Lisp system as
;;; possible into Read-Only and Static spaces so that subsequent garbage
;;; collections are quicker.  We purify in two passes, one of which is done
;;; by Lisp code, and one of which is done by microcode in a slightly-modified
;;; GC.  The first pass attempts to copy all of the constants associated with
;;; every reachable function object in the system into Read-Only space.  The
;;; structures are copied recursively.  Each component of these constant
;;; stuctures should be either static (a symbol) or reachable only from its
;;; parent structure.  If not, we will lose.  The second pass sets the free
;;; pointers for the newspaces to be the free pointers for the corresponding
;;; static or read-only spaces and then GC's.
;;;
;;; PURIFICATION WILL WORK ONLY IF ALL SYMBOLS ARE ALLOCATED IN STATIC SPACE.
;;;

(defun purify ()
  (write-line "Copying constants of live functions...")
  (set-free-pointer-to-static-space %bit-vector-type)
  (set-free-pointer-to-static-space %integer-vector-type)
  (set-free-pointer-to-static-space %string-type)
  (set-free-pointer-to-static-space %bignum-type)
  (set-free-pointer-to-static-space %long-float-type)
  (set-free-pointer-to-read-only-space %complex-type)
  (set-free-pointer-to-read-only-space %ratio-type)
  (set-free-pointer-to-static-space %general-vector-type)
  (set-free-pointer-to-read-only-space %function-type)
  (set-free-pointer-to-read-only-space %array-type)
  (set-free-pointer-to-static-space %symbol-type)
  (set-free-pointer-to-static-space %list-type)
  (do-all-symbols (symbol)
    (if (fboundp symbol)
	(purify-function-object symbol)))
  (write-line "Collecting stuff into static and read-only spaces...")
  (gc nil)
  (set-static-space-from-free-pointer %bit-vector-type)
  (set-static-space-from-free-pointer %integer-vector-type)
  (set-static-space-from-free-pointer %string-type)
  (set-static-space-from-free-pointer %bignum-type)
  (set-static-space-from-free-pointer %long-float-type)
  (set-read-only-space-from-free-pointer %complex-type)
  (set-read-only-space-from-free-pointer %ratio-type)
  (set-static-space-from-free-pointer %general-vector-type)
  (set-read-only-space-from-free-pointer %function-type)
  (set-read-only-space-from-free-pointer %array-type)
  (set-static-space-from-free-pointer %symbol-type)
  (set-static-space-from-free-pointer %list-type)
  (set-free-pointer-to-start %bit-vector-type)
  (set-free-pointer-to-start %integer-vector-type)
  (set-free-pointer-to-start %string-type)
  (set-free-pointer-to-start %bignum-type)
  (set-free-pointer-to-start %long-float-type)
  (set-free-pointer-to-start %complex-type)
  (set-free-pointer-to-start %ratio-type)
  (set-free-pointer-to-start %general-vector-type)
  (set-free-pointer-to-start %function-type)
  (set-free-pointer-to-start %array-type)
  (set-free-pointer-to-start %symbol-type)
  (set-free-pointer-to-start %list-type)
  (write-line "Purification is complete.")
  nil)

;;; Purify-Function-Object copies all of the boxed stuff pointed to by the
;;; function object into read-only space.  The function object that is the
;;; definition of the symbol handed to us will either be a list or a compiled
;;; function object.  In the latter case, we just hack the constants of the
;;; function and don't bother to rewrite the definition cell.  This should buy
;;; us something in paging performance, since nearly all functions will be like
;;; this.

(defun purify-function-object (name)
  (let ((function (symbol-function name)))
    (cond ((compiled-function-p function)
	   (purify-function-constants function))
	  ((eq (car function) 'macro)
	   (purify-function-constants (cdr function)))
	  ((eq (car function) '%compiled-closure%)
	   (purify-function-constants (third function))))))

(defun purify-function-constants (function)
  (do ((index %function-arg-names-slot (1+ index))
       (length (%primitive header-length function)))
      ((= index length))
    (%primitive header-set function index
		(purify-object (%primitive header-ref function index)))))

;;; Purify-Object returns the purifed form of a given object.  If the object is
;;; of an immediate type, an unboxed type, or allocated in static or read-only
;;; space already, it is pure.  Otherwise we copy it.

(defmacro pure-p (object)
  `(let ((%type (%primitive get-type ,object)))
     (or (>= %type %fixnum-type)		; Immediate
	 (< %type %complex-type)		; Unboxed
	 (> (%primitive get-space ,object) 1)	; Static or Read-Only
	 )))

(defun purify-object (object)
  (cond ((pure-p object) object)
	((complexp object)
	 (error "Complex number ain't supported!"))
	((ratiop object)
	 (%primitive make-ratio (numerator object) (denominator object)))
	((simple-vector-p object)
	 (let* ((length (length (the simple-vector object)))
		(new (%primitive alloc-g-vector length ())))
	   (do ((index 0 (1+ index)))
	       ((= index length) object)
	     (setf (svref new index) (purify-object (svref object index))))
	   new))
	((compiled-function-p object)
	 (error "Oh baz.  I'm too quick and dirty to copy ~S." object))
	((arrayp object)
	 (error "Oh baz.  I'm too quick and dirty to copy ~S." object))
	((symbolp object)
	 (error "Barfo!  I hit a dynamic symbol, ~S!" object))
	((listp object)
	 (cons (purify-object (car object))
	       (purify-object (cdr object))))
	(t
	 (error "Barfo!  I hit this weird thing, ~S!" object))))

;;; Set-Free-Pointer-To-Static-Space and Set-Free-Pointer-To-Read-Only-Space
;;; set the free and clean pointers for the newspace of the specified Type to
;;; be the free pointer of static its or read-only space, as specified.

(defun set-free-pointer-to-static-space (type)
  (set-free-pointer-to-space type 2))

(defun set-free-pointer-to-read-only-space (type)
  (set-free-pointer-to-space type 3))

(defun set-free-pointer-to-space (type space)
  (let* ((next-newspace (logxor (%primitive newspace-bit) 1))
	 (base (ash type 4))
	 (free (logior base (ash space 2)))
	 (new (logior base (ash next-newspace 2))))
    (%primitive 16bit-system-set alloctable-address new
		(%primitive 16bit-system-ref alloctable-address free))
    (%primitive 16bit-system-set alloctable-address (+ new 1)
		(%primitive 16bit-system-ref alloctable-address (+ free 1)))
    (%primitive 16bit-system-set alloctable-address (+ new 2)
		(%primitive 16bit-system-ref alloctable-address free))
    (%primitive 16bit-system-set alloctable-address (+ new 3)
		(%primitive 16bit-system-ref alloctable-address (+ free 1)))))

;;; Set-Free-Pointer-To-Start sets the free pointer for a given Type's
;;; new dynamic space to the start of that space.

(defun set-free-pointer-to-start (type)
  (let ((new (logior (ash type 4) (ash (%primitive newspace-bit) 2))))
    (%primitive 16bit-system-set alloctable-address new 0)
    (%primitive 16bit-system-set alloctable-address (+ new 1) (ash new 7))))

;;; Set-Static-Space-From-Free-Pointer and
;;; Set-Read-Only-Space-From-Free-Pointer set the static or read-only space
;;; free pointer for the given Type to that of the newspace for that type.

(defun set-static-space-from-free-pointer (type)
  (set-foo-from-free-pointer type 2))

(defun set-read-only-space-from-free-pointer (type)
  (set-foo-from-free-pointer type 3))

(defun set-foo-from-free-pointer (type space)
  (let* ((base (ash type 4))
	 (free (logior base (ash (%primitive newspace-bit) 2)))
	 (foo (logior base (ash space 2))))
    (%primitive 16bit-system-set alloctable-address foo
		(%primitive 16bit-system-ref alloctable-address free))
    (%primitive 16bit-system-set alloctable-address (+ foo 1)
		(%primitive 16bit-system-ref alloctable-address (+ free 1)))))