;	Tueþy0ùA Oct 17,1978  17:39  FM+1D.6H.12M.18S.  -*- Lisp -*-

;;; Functions for creating heirachical MACLISP dumps on ITS.
;;; This will work with (STATUS FLUSH) either T or NIL.

;;; Comments, complaints, suggestions, etc. to GSB@ML

;;;  A pure dump is made by loading up functions and data into a lisp
;;; which has had *PURE set to T and PURE either a small fixnum or
;;; T.  (NIL will cause it to lose!)
;;;  To dump, you probably want to (SETQ *PURE NIL), then call
;;; PURE-SUSPEND (rather than SUSPEND) with 2 arguments,
;;; one an argument to pass to suspend (NIL will use the value of
;;; *SUSPEND-DEFAULT-ARGUMENT, which is initialised to something
;;; reasonable, like ":PDUMPED^M"), and the name of the file to
;;; pdump it to.  All components of the filename must be explicitly
;;; specified, since this package needs to remember exactly which
;;; file it was dumped to.  For this reason, it is preferable to
;;; dump new versions with numeric second filenames, and have links
;;; from the TS file to either a specific version or the '>' version.
;;; (EG, LMS is dumped to DSK:LMS;.LMS > .  Note however that you
;;; can't give '>' as a component to PURE-SUSPEND;  you must figure
;;; out what version will be generated and specify it.  In most cases
;;; this is done anyway, to figure out what your version number is.)

;;; The primary operation here is the function COMMUNIZE, which
;;; opens up all the files which the dump has been generated from,
;;; and maps in pages from them so as to optimize sharing between
;;; jobs which come from those files.
;;; *SUSPEND takes from 0 to 2 arguments, calls SUSPEND with them,
;;; and then calls COMMUNIZE.
;;; PURE-SUSPEND does a general purification, suspend, and communize.

;;; Hackers note - 
;;; This only maps in pure pages from a file, and only pages which are
;;; not absolute.  (It does not recognize public pages though.)  
;;; It will not clobber an impure page in the job with a pure page from
;;; a file.  If, however, an earlier dump has had a patch put into a
;;; pure area and the page has been repurified, then that change will
;;; propagate to all dumps made from that one.
;;; It is also willing to map a pure page in over a non-existent page,
;;; in case you are going to do something perverse like flush portions of
;;; your binary program space before saving.

(declare (special *sharing-file-list *suspend-default-argument))

(or (boundp '*sharing-file-list) (setq *sharing-file-list nil))

(or (boundp '*suspend-default-argument)
    (setq *suspend-default-argument
	  (cond ((eq (status hactrn) 'ddt)
		    ;; This is the normal default that
		    ;; the function SUSPEND provides.
		    '|:PDUMPED/î|)
		(t ;; This causes suspend to execute a
		   ;; .BREAK 16,300000  which causes the
		   ;; job to simply return to its superior.
		   98304.))))

(declare (special *lisp-pure-pages))

(or (boundp '*lisp-pure-pages)
    (do ((i 0 (1+ i)) (l))
	((= i 256.) (setq *lisp-pure-pages l))
      (and (plusp (car (syscall 1 'cortyp i))) (setq l (cons i l)))))

(defun pure-suspend (argument-to-suspend file-to-dump-to)
  (prog ()

   recover-from-wrong-type-arg

       (setq file-to-dump-to (namelist file-to-dump-to))

       (cond
	((or (memq (cadr file-to-dump-to) '(* /> /<))
	     (memq (caddr file-to-dump-to) '(* /> /<))
	     (eq (caar file-to-dump-to) '*)
	     (eq (cadar file-to-dump-to) '*))
	 (setq file-to-dump-to
	       (error
		 '|Unspecified filename component - SUSPEND et al|
		 file-to-dump-to
		 'wrng-type-arg))
	 (go recover-from-wrong-type-arg)))

       ;; Round up binary program space to a page boundary.
       ;; (This should not be necessary but lisp may or
       ;; may not be smart enough to do so itself.  Doing it
       ;; redundantly is a no-op.)
       (pagebporg)

       ;; Now, do the purification.  This purifies all binary
       ;; program space, and also list structure etc. which 
       ;; was 'purcopied'.
       (purify 0 0 'bporg)

       ;; Save away the name of the file we are dumping to.
       (setq *sharing-file-list
	     (cons file-to-dump-to *sharing-file-list))

       ;; And finally, suspend.
       (suspend (or argument-to-suspend *suspend-default-argument)
		file-to-dump-to)

       ;; Now, since we are suspended, map in the pages from
       ;; other files.
       (communize)

       (return t)))

(defun *suspend number-of-arguments
   ;; Suspend, then communize.
   ;; Note that here the exact specification of the filename 
   ;; is not critical here, this function does no purification.
   (cond ((= number-of-arguments 0) (suspend))
	 ((= number-of-arguments 1) (suspend (arg 1)))
	 (t (suspend (arg 1) (arg 2))))
   (communize))

;;; It may be desirable to open a single file array, and re-use
;;; it by using the function CNAMEF;  this will lessen gc
;;; thrashing due to making many file arrays.

(defun communize ()
   ((lambda (array-pointer)
       (mapc '(lambda (x)
		  (communize-single-file x array-pointer))
	     *sharing-file-list)
       (*rearray array-pointer)
       t)
    (*array nil 'fixnum 256.)))

(defun communize-single-file (filename array-pointer)
  (cond ((not (probef filename))
	   (princ '|/î; The file | msgfiles)
	   (prin1 (namestring filename) msgfiles)
	   (princ '| is not there;/î; sharing will not be optimal.|
		  msgfiles))
	(t ((lambda (file-object)
		;; Note the use of unit mode.
		;; This keeps the file array smaller (no buffer)
		(map-in-pure-pages-from-file file-object
					     array-pointer)
		(close file-object))
	    (open filename '(in fixnum single))))))

(defun map-in-pure-pages-from-file (file-object array-pointer)
  (cond
    ((not (= (in file-object) 0))
       (princ '|/î; The file | msgfiles)
       (prin1 (namestring (truename file-object)) msgfiles)
       (princ '| is not in PDUMP format;| msgfiles)
       (princ '|; Someone is losing grossly!| msgfiles))
    (t (fillarray array-pointer file-object)
       (do ((page-number 0 (1+ page-number))
	    (entry) (file-page-number 1))
	   ((= page-number 256.))
	 (declare (fixnum page-number entry))
	 (setq entry (arraycall fixnum array-pointer page-number))
	 (and ;; Negative means absolute page; zero non-existent.
	      (plusp entry)
	      ;; Read-only page iff bit 2.8 is 1 and 2.9 is 0.
	      (= (boole 3. (lsh entry -16.)) 1.)
	      ;; And it's not already sharing the basic lisp
	      (not (member page-number *lisp-pure-pages))
	      ;; And it's a pure (unpatched?) page in us
	      (not (minusp (car (syscall 1 'cortyp page-number))))
	      ;; then map it in!
	      (map-in-page-from-file file-object
				     page-number
				     file-page-number))
	 ;; Determine whether there was a page in the file
	 ;; corresponding to PAGE-NUMBER.
	 (and (plusp entry)
	      (plusp (boole 1 3. (lsh entry -16.)))
	      (setq file-page-number (1+ file-page-number)))))))

(defun map-in-page-from-file (file-object page-number file-page-number)
   (declare (fixnum page-number))
   ((lambda (syscall-corblk-result)
	;;  Non-null indicates an error.
	(cond ((not (null syscall-corblk-result))
	       ((lambda (args) (break |(SYSCALL 'CORBLK) lost|))
		(list file-object page-number 
		      syscall-corblk-result)))))
    (syscall 0 'corblk 4096. -1 page-number
	     file-object file-page-number)))