mirror of
https://github.com/PDP-10/its.git
synced 2026-01-27 20:47:38 +00:00
748 lines
26 KiB
Common Lisp
Executable File
748 lines
26 KiB
Common Lisp
Executable File
;;; SHARAB -*-LISP-*-
|
||
;;; **************************************************************
|
||
;;; ***** MACLISP ****** Sharable Extensions to LISP *************
|
||
;;; **************************************************************
|
||
;;; ** (C) Copyright 1981 Massachusetts Institute of Technology **
|
||
;;; ****** This is a read-only file! (All writes reserved) *******
|
||
;;; **************************************************************
|
||
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
(setq defmacro-for-compiling () defmacro-displace-call () )
|
||
(setq macros () IBASE 8. BASE 8.)
|
||
)
|
||
|
||
|
||
|
||
;;; Following temporary macro is nearly an open-coding of HERALD, but
|
||
;;; differs so that the "version" number is available when compiling
|
||
(defmacro C-HERALD
|
||
(group-name &optional (version-number '||) (ofile 'MSGFILES))
|
||
(or (symbolp group-name)
|
||
(check-type group-name #'SYMBOLP 'HERALD))
|
||
(let* ((ifile (and (filep infile)
|
||
(car (last (truename infile)))))
|
||
(v (cond ((and ifile
|
||
(fixp (car (errset (readlist (exploden ifile)) () ))))
|
||
ifile)
|
||
((symbolp version-number) version-number)
|
||
('||)))
|
||
(putpropper `(DEFPROP ,group-name ,v VERSION))
|
||
(text (symbolconc '|;Loading | group-name '| | v)) )
|
||
(setq text (copysymbol text () ))
|
||
(set text text)
|
||
(putprop text 'T '+INTERNAL-STRING-MARKER)
|
||
(if (status feature COMPLR) (putprop text `(SPECIAL ,text) 'SPECIAL))
|
||
;; Remember, this is a maclisp-only file!
|
||
;;In older lisps, or for cross-compilation, we simply forget
|
||
;; about delaying-until-exit the putprop of version number.
|
||
(setq putpropper
|
||
`(COND ((ALPHALESSP (STATUS LISPV) '/2071) ,putpropper)
|
||
('T (PUSH #'(LAMBDA (X) (OR X ,putpropper))
|
||
FILE-EXIT-FUNCTIONS))))
|
||
(putprop group-name v 'C-VERSION)
|
||
`(PROGN
|
||
(COND ((STATUS NOFEATURE NOLDMSG)
|
||
(TERPRI ,ofile)
|
||
(PRINC ,text ,ofile)))
|
||
,putpropper
|
||
',v)))
|
||
|
||
;; (SELECT-A-BIT? x b1 b2 ... bn) is true iff 'x' has one of the selected
|
||
;; bits turned on; bit 'i', selected by 'bi' is 2^i
|
||
(defmacro SELECT-A-BIT? (val &rest l)
|
||
(let ((n (apply 'plus (mapcar '(lambda (x) (lsh 1 x)) l))))
|
||
`(NOT (= (BOOLE 1 ,val ,n) 0))))
|
||
|
||
(defmacro CLEAR-BITS (mask val) `(BOOLE 2 ,mask ,val))
|
||
|
||
|
||
|
||
|
||
;;; WARNING!! You loser, don't ever let the version number run over
|
||
;;; two digits. The 2nd filename "JONLxx" will lose, and also the
|
||
;;; 2nd filename of the dump file will lose ("SHBDMP xx.yyy" where
|
||
;;; "yyy" is the lisp version number over which the SHARABLE is built).
|
||
|
||
(c-herald SHARABLE /47)
|
||
|
||
;;; Functions for creating heirachical MACLISP dumps on ITS.
|
||
;;; PURE-SUSPEND - suspend, but also delete pure pages that are shared with
|
||
;;; previous dumps, re-sharing them upon loading. No deletions
|
||
;;; are done unless PURE-SUSPEND is non-() and also unless
|
||
;;; (status FLUSH) ==> T; but regardless of deletions, starting
|
||
;;; up after a call to PURE-SUSPEND will cause sharing with the
|
||
;;; previous dumped files. Two arguments required - both passed
|
||
;;; to SUSPEND (q.v.) - but the second is analyzed as a file
|
||
;;; name and will cause a proceedable break loop if PDUMPing
|
||
;;; by SUSPEND will clobber an existing file.
|
||
;;; ANNOUNCE-&-LOAD-INIT-FILE - Handy little function for systems that want to
|
||
;;; to announce themselves upon loading, and try to load an
|
||
;;; "init" file. See the file JONL;SHARAB LISP for an example.
|
||
;;; First argument is a symbol, which is the "name" to be
|
||
;;; announced (if there is a VERSION property on this symbol, it
|
||
;;; will be included in the "announcement"); optional second
|
||
;;; argument is either () or a list of characters like returned
|
||
;;; by (STATUS JCL) to be parsed as filename to be used instead
|
||
;;; of the usual init file. If a third argument is supplied, it
|
||
;;; is a "fix" file to be loaded before loading the "name" init
|
||
;;; file.
|
||
;;; DEPURIFY-SYMBOL - depurifies, so that if pure pages have been deleted ...
|
||
;;; The value of DEPURIFY-SYMBOL is a list of symbols which
|
||
;;; must never be purified, since they are needed during the
|
||
;;; "chilly" load of the system.
|
||
|
||
;;; Hacked up during February 1980, by JONL, from the NSHARE file of GSB
|
||
;;; Comments, complaints, suggestions, etc. to BUG-LISP
|
||
|
||
;;; For Optimal sharing, this file should be loaded into a nearly fresh
|
||
;;; lisp, with PURE bound to T; in this case, *PURE ###must### be
|
||
;;; bound to () during the loading of this file.
|
||
;;; Then a pure dump is made by loading up other functions and data
|
||
;;; with *PURE set to T, and PURE set either to a small fixnum or to T.
|
||
;;; When finished loading, you probably want to set *PURE to (), and then
|
||
;;; call PURE-SUSPEND (rather than SUSPEND) with 2 arguments - the second
|
||
;;; arg is the name of the file to PDUMP into, and the first is passed to
|
||
;;; SUSPEND. If the first arg is (), then SUSPEND merely does the PDUMP
|
||
;;; and returns; if it is 0, SUSPEND will valret to DDT after PDUMPing.
|
||
|
||
;;; 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 also tries to distinguish a page which has been patchd and
|
||
;;; repurified, but is not part of a dumped file.
|
||
|
||
|
||
(declare (special *SHARING-FILE-LIST* |+internal-page-map/||
|
||
PURE-SUSPEND COMMUNIZE-SINGLE-FILE COMMUNIZE-FILE-ARRAY
|
||
ANNOUNCE-&-LOAD-INIT-FILE )
|
||
(*expr PURE-SUSPEND COMMUNIZE-SINGLE-FILE)
|
||
(*lexpr ANNOUNCE-&-LOAD-INIT-FILE)
|
||
(special JOB-MSG-FILE)
|
||
(setq USE-STRT7 'T))
|
||
|
||
;;; Can only play the FLUSH game if this file is loaded with PURE = T
|
||
;;; Otherwise, you may try to "CALL 1 'CONS" during COMMUNIZE, and find
|
||
;;; that the plist of CONS was on a pure page which is not yet back!
|
||
(eval-when (load)
|
||
(or (eq pure 'T) (error '|PURE must be "T" when loading SHARABLE|))
|
||
)
|
||
|
||
(setq-if-unbound *SHARING-FILE-LIST* ()
|
||
PURE-SUSPEND 'T
|
||
|+internal-page-map/|| () )
|
||
(setq ANNOUNCE-&-LOAD-INIT-FILE (status LISPV))
|
||
|
||
;;; Information about the purity of pages is stored in a fixnum array,
|
||
;;; packed 8 4-bit bytes per word. Meaning of the 4 bits is:
|
||
;;; 0 - non-existent page
|
||
;;; 1 (1_0) - writeable page
|
||
;;; 2 (1_1) - LISP system pure page
|
||
;;; 4 (1_2) - other pure page
|
||
;;; 8 (1_3) - temporary setting for purity, just before suspension
|
||
;;; This array, "|+internal-page-map/||", is set up at the end of this file.
|
||
|
||
(defmacro (LDB-A-BYTE defmacro-for-compiling () defmacro-displace-call () )
|
||
(&optional (index 'PAGE-NUMBER)
|
||
(byte-size 4)
|
||
(bytes-per-word 8)
|
||
(ar '|+internal-page-map/||))
|
||
`(LOAD-BYTE (ARRAYCALL FIXNUM ,ar (// ,index ,bytes-per-word))
|
||
(* ,byte-size (\ ,index ,bytes-per-word))
|
||
,byte-size))
|
||
|
||
(defmacro (DPB-A-BYTE defmacro-for-compiling () defmacro-displace-call () )
|
||
(byte &optional (index 'PAGE-NUMBER)
|
||
(byte-size 4)
|
||
(bytes-per-word 8)
|
||
(ar '|+internal-page-map/||)
|
||
&aux wordno remwordno body)
|
||
(cond ((and (fixnump index) (fixnump bytes-per-word))
|
||
(setq wordno (* index bytes-per-word)
|
||
remwordno (\ index bytes-per-word)))
|
||
('T (si:gen-local-var wordno)
|
||
(si:gen-local-var remwordno)))
|
||
(setq body `(STORE (ARRAYCALL FIXNUM ,ar ,wordno)
|
||
(DEPOSIT-BYTE (ARRAYCALL FIXNUM ,ar ,wordno)
|
||
(* ,byte-size ,remwordno)
|
||
,byte-size
|
||
,byte)))
|
||
;;Foo - don't we wish we had a multiple-value-returning version of
|
||
;; division, which also returned the remainder!
|
||
(if (not (fixnump wordno))
|
||
(setq body `(LET ((,wordno (// ,index ,bytes-per-word))
|
||
(,remwordno (\ ,index ,bytes-per-word)))
|
||
(DECLARE (FIXNUM ,wordno ,remwordno))
|
||
,body)))
|
||
body)
|
||
|
||
|
||
(comment PURE-SUSPEND)
|
||
|
||
(putprop 'PURE-SUSPEND (lsh bporg -10.) 'BPORG)
|
||
|
||
|
||
(defun PURE-SUSPEND (argument-to-suspend file-namelist)
|
||
(prog (*PURE NORET flushp oni b-low b-hi npurep purepage? tpno tmp
|
||
file-object file-to-dump-to open-files flstbl flstbl-addr )
|
||
(declare (fixnum b-low b-hi npurep purepage? tpno flstbl flstbl-addr))
|
||
(setq npurep -1 purepage? 0 tpno 0)
|
||
(setq b-low (1- (or (get 'PURE-SUSPEND 'BPORG) 1000.))
|
||
b-hi (1+ (or (get 'PURE-SUSPEND 'BPEND) -1000.)))
|
||
(setq flushp (and PURE-SUSPEND (status FLUSH)))
|
||
FIND-FILE
|
||
(cond ((probef file-namelist)
|
||
(terpri)
|
||
(prin1 file-namelist)
|
||
(princ '| will :PDUMP over existing file ?/
|
||
P to go ahead, or RETURN another file name/î|)
|
||
(cond ((setq tmp (+internal-fac-break file-namelist))
|
||
(setq file-namelist tmp)
|
||
(go FIND-FILE)))))
|
||
(setq file-object (open file-namelist '(OUT FIXNUM SINGLE))
|
||
file-to-dump-to (truename file-object))
|
||
FIND-FLSTBL
|
||
(cond ((null flushp) () )
|
||
((null (setq tmp (cond ((getddtsym 'FLSTBL))
|
||
((eq (status hactrn) 'DDT)
|
||
(valret '|:SYMLOD/î:VP |)
|
||
(getddtsym 'FLSTBL)))))
|
||
(princ '|/îDDT symbols?|)
|
||
(+internal-fac-break () )
|
||
(go FIND-FLSTBL))
|
||
('T (setq FLSTBL tmp)
|
||
;Unpurify symbols of the file's namelist - so can call OPEN
|
||
; after dumping, but before pure data pages are loaded in.
|
||
(mapc 'DEPURIFY-SYMBOL (append (car file-to-dump-to)
|
||
(cdr file-to-dump-to)))))
|
||
(cond ((null argument-to-suspend))
|
||
((not (eq (status hactrn) 'DDT))
|
||
(setq argument-to-suspend () ))
|
||
((symbolp argument-to-suspend)
|
||
(depurify-symbol argument-to-suspend)))
|
||
(close file-object)
|
||
(setq file-object () )
|
||
(and (boundp 'JOB-MSG-FILE) ;just in case LDDT is here
|
||
(filep JOB-MSG-FILE)
|
||
(setq tmp (status filemo JOB-MSG-FILE))
|
||
(push (cons JOB-MSG-FILE tmp) open-files))
|
||
;; First, set up some data passed in thru special variable
|
||
;; Since this can do a GC, we must do it before we flush any pages.
|
||
(setq COMMUNIZE-SINGLE-FILE (*array () 'FIXNUM 256.))
|
||
(gctwa)
|
||
; Since NORET is bound to NIL, this should minimize BPS pages
|
||
(gc)
|
||
; This GC may close a few "lost" files
|
||
(do ((l (munkam (examine (getddtsym 'GCMKL))) (cddr l))
|
||
(dedsar (getddtsym 'DEDSAR))
|
||
(losing-files) )
|
||
((null l)
|
||
(cond (losing-files
|
||
(terpri)
|
||
(prin1 losing-files)
|
||
(princ '|/îFiles open during PURE-SUSPEND -- P to close them/î|)
|
||
(+internal-fac-break losing-files)
|
||
(mapc 'CLOSE losing-files ))))
|
||
(cond ((or (eq (car l) dedsar)
|
||
(not (filep (car l)))
|
||
(null (setq tmp (status filemode (car l)))) )
|
||
() )
|
||
((not (memq 'TTY (car tmp))) (push (car l) losing-files))
|
||
((and (not (eq (car l) TYI)) (not (eq (car l) TYO)))
|
||
(push (cons (car l) (car tmp)) open-files))))
|
||
|
||
;; Round up binary program space to a page boundary. (This should
|
||
;; not be necessary but user's program may fail to do it.)
|
||
(pagebporg)
|
||
;; Now, do the purification. This purifies all binary program space,
|
||
;; a and also list structure etc. which was 'purcopied'.
|
||
(purify 0 0 'BPORG)
|
||
;; Save away the name of the file we are dumping to, in effect by
|
||
;; (push tmp (cdr *sharing-file-list*))
|
||
(setq tmp (list file-to-dump-to))
|
||
(cond ((null *SHARING-FILE-LIST*) (setq *SHARING-FILE-LIST* tmp))
|
||
('T (rplacd tmp (cdr *SHARING-FILE-LIST*))
|
||
(rplacd *SHARING-FILE-LIST* tmp)))
|
||
(do ((l open-files (cdr l)))
|
||
((null l))
|
||
(close (caar l)))
|
||
|
||
;; The next phase must be indivisible - hence NOINTERRUPT
|
||
(setq oni (nointerrupt 'T))
|
||
(let ((BASE 10.)
|
||
(*NOPOINT 'T)
|
||
f date time PRINLEVEL PRINLENGTH)
|
||
(do ((i 3 (1- i)))
|
||
((or (< i 0)
|
||
(errset (setq f (open '|DSK:LISP;LOCK MAIL| '(APPEND))) ()))
|
||
(cond ((< i 0)
|
||
(errset (renamef '|DSK:LISP;LOCK MAIL|
|
||
'|DSK:LISP;LCKMAI >|)
|
||
() )
|
||
(setq f (open '|DSK:LISP;LOCK MAIL| '(OUT))))))
|
||
(terpri tyo)
|
||
(princ '|LOCK MAIL file not available -- waiting 10 seconds.| tyo)
|
||
(sleep 10.))
|
||
(setq date (status date)
|
||
time (status daytime))
|
||
(terpri f)
|
||
(princ (status USERID) f)
|
||
(princ '| | f)
|
||
(princ (cadr date) f)
|
||
(princ '// f)
|
||
(princ (caddr date) f)
|
||
(princ '// f)
|
||
(princ (car date) f)
|
||
(princ '| | f)
|
||
(princ (car time) f)
|
||
(princ '/: f)
|
||
(princ (cadr date) f)
|
||
(princ '/: f)
|
||
(princ (caddr date) f)
|
||
(terpri f)
|
||
(prin1 (cons ANNOUNCE-&-LOAD-INIT-FILE *SHARING-FILE-LIST*) f)
|
||
(terpri f)
|
||
(princ '| | f)
|
||
(close f))
|
||
(|+internal-call/|| () 'INIT)
|
||
;; Remember any newly shared pages, and disconnect others if flushing
|
||
(do ((page-number 0 (1+ page-number)))
|
||
((not (< page-number 256.)))
|
||
(declare (fixnum page-number))
|
||
(setq npurep (cond ((lessp b-low page-number b-hi)
|
||
;; This page needed for restart after SUSPEND, so
|
||
;; mark as "other pure", but not cuttable.
|
||
1_2)
|
||
((zerop (setq tpno (|+internal-call/|| page-number 'CORTYP)))
|
||
;; 0 ==> page doesn't exist, negative ==> impure
|
||
0)
|
||
((< tpno 0)
|
||
;; add 1_0 bit, and clear others except 1_1
|
||
(logior 1_0 (clear-bits #o15 (ldb-a-byte))) )
|
||
('T -1)))
|
||
(cond ((not (< npurep 0)) (dpb-a-byte npurep))
|
||
;; If npurep = -1, then page is pure, and is a candidate for
|
||
;; for cutting out from pdump.
|
||
((select-a-bit? (setq tpno (ldb-a-byte)) 1)
|
||
;; 1_1-bit of internal-page-map says, "LISP" system pure page
|
||
(setq flstbl-addr (+ flstbl (// page-number 36.)))
|
||
(and (cond ((null (|+internal-call/|| page-number 'DSK))
|
||
;; But what if it was just patched? Then diddle
|
||
;; table SUSPEND uses, so that it isn't flushed
|
||
(setq purepage? 0)
|
||
;; Also mark it as a "newly-shared" page
|
||
(setq tpno #.(+ 1_3 1_1) )
|
||
'T)
|
||
((select-a-bit? tpno 2)
|
||
;; If dumped in previous round, then permit
|
||
;; SUSPEND to flush it in this round
|
||
(setq purepage? 1)
|
||
;; Call it a "system" page, since SUSPEND will
|
||
;; flush it in the future
|
||
(setq tpno 1_1)
|
||
'T))
|
||
(deposit flstbl-addr
|
||
(deposit-byte (examine flstbl-addr)
|
||
(- 35. (\ page-number 36.))
|
||
1
|
||
purepage?))
|
||
(dpb-a-byte tpno)))
|
||
((select-a-bit? tpno 2 3)
|
||
;Try to flush page from this job, if random shared page
|
||
(and flushp (|+internal-call/|| page-number 'FLUSH)))
|
||
('T ;; Otherwise Mark as "newly-purified" page
|
||
;; (maybe flush next in next cascade pdump?)
|
||
(dpb-a-byte 1_3) )))
|
||
;; And finally, suspend.
|
||
(suspend argument-to-suspend file-to-dump-to)
|
||
(if flushp
|
||
(do ((page-number 0 (1+ page-number)))
|
||
((not (< page-number 256.)))
|
||
(declare (fixnum page-number))
|
||
;;Any page that was "newly purified" just before SUSPENDing
|
||
;; is now a random sharable pure page, and may be cut out on
|
||
;; subsequent dumps. So mark it in the internal-page-map.
|
||
(and (select-a-bit? (setq tpno (ldb-a-byte)) 3)
|
||
(dpb-a-byte (logior 1_2 (clear-bits 1_3 tpno))))))
|
||
(nointerrupt oni)
|
||
;; Now, since we are suspended, map in the pages from other files
|
||
;; found on *SHARING-FILE-LIST*, which restores the "1_2" pages
|
||
(mapc 'COMMUNIZE-SINGLE-FILE *SHARING-FILE-LIST*)
|
||
(*rearray COMMUNIZE-SINGLE-FILE)
|
||
(do ((l open-files (cdr l)))
|
||
((null l))
|
||
(open (caar l) (cadar l)))
|
||
(return 'T)))
|
||
|
||
|
||
(defun COMMUNIZE-SINGLE-FILE (file-namelist)
|
||
(prog (file-page-number entry purepage? tmp)
|
||
(declare (fixnum entry purepage? file-page-number))
|
||
(setq entry 0
|
||
file-page-number 1)
|
||
;; Unit mode: keeps the file array smaller (no buffer)
|
||
(cnamef COMMUNIZE-FILE-ARRAY file-namelist)
|
||
(setq tmp (errset (open COMMUNIZE-FILE-ARRAY '(IN FIXNUM SINGLE))))
|
||
(cond ((or (atom tmp) (not (= (in COMMUNIZE-FILE-ARRAY) 0)))
|
||
(princ '|;File not shared since it | msgfiles)
|
||
(prin1 file-namelist msgfiles)
|
||
(cond ((atom tmp)
|
||
(princ '| could not be opened| msgfiles))
|
||
((princ '| is not in PDUMP format| msgfiles)))
|
||
; (princ tmp msgfiles)
|
||
(return (close COMMUNIZE-FILE-ARRAY))))
|
||
;; Try to COMMUNIZE-SINGLE-FILE here!
|
||
;; Get page map from first block of file - 256. words
|
||
(fillarray COMMUNIZE-SINGLE-FILE COMMUNIZE-FILE-ARRAY)
|
||
(do ((page-number 0 (1+ page-number)))
|
||
((not (< page-number 256.)))
|
||
(declare (fixnum page-number))
|
||
(setq entry (arraycall fixnum COMMUNIZE-SINGLE-FILE page-number))
|
||
(cond ((plusp entry)
|
||
;; < 0 ==> absolute page; = 0 ==> non-existent page
|
||
(setq purepage? (load-byte entry 16. 2))
|
||
;; File contains a page corresponding to PAGE-NUMBER?
|
||
(or (plusp purepage?)
|
||
(error 'COMMUNIZE-SINGLE-FILE))
|
||
(and
|
||
;; Read-only iff bits <2.9,2.8> is 01
|
||
(= purepage? 1.)
|
||
;; Tbl entry is 1 if page is writeable in most recent dump
|
||
(not (select-a-bit? (ldb-a-byte) 0))
|
||
;; If not in us, or unpatched-pure in us
|
||
(not (minusp (|+internal-call/|| page-number 'CORTYP)))
|
||
;; then map it in!
|
||
(setq tmp (fetch-file-page/| page-number
|
||
COMMUNIZE-FILE-ARRAY
|
||
file-page-number))
|
||
;; Non-null indicates an error.
|
||
(error 'CORBLK))
|
||
(setq file-page-number (1+ file-page-number)))))
|
||
(close COMMUNIZE-FILE-ARRAY)))
|
||
|
||
|
||
|
||
(lap-a-list '(
|
||
(lap |+internal-call/|| subr)
|
||
(args |+internal-call/|| (() . 2)) ;a kind of "SYSCALL"
|
||
(defsym *ruind 23 ; 2nd arg is "message"
|
||
**rlfi 2
|
||
f*chan 11)
|
||
(defsym immed-info 1000_22 ;arg ptrs for "CALL" uuo
|
||
get-info 2000_22
|
||
get-error 3000_22
|
||
immed-control 5000_22 )
|
||
(cain 2 'CORTYP) ;"CORTYP" to do a "CORTYP" call
|
||
(jrst 0 do-cortyp)
|
||
(cain 2 'FLUSH) ;"FLUSH" to do a "CORBLK" call
|
||
(jrst 0 do-flush) ; to delete a page from our map
|
||
(cain 2 'DSK) ;"DSK" to find out if argument
|
||
(jrst 0 dsk-sharedp) ; page is shared with dsk file
|
||
(cain 2 'INIT) ;"INIT" to initialize above
|
||
(jrst 0 dsk-sharedp-init)
|
||
(cain 2 'FILE) ;"FILE" for finding file which
|
||
(jrst 0 who-bore-me?) ; was loaded to make this job
|
||
(lerr 0 (% sixbit |BAD MSG TO +internal-call!|))
|
||
|
||
do-flush
|
||
(jsp t fxnv1)
|
||
(*call 0 flush-request)
|
||
(*lose)
|
||
(jrst 0 fix1)
|
||
flush-request
|
||
(setz)
|
||
(sixbit |CORBLK|)
|
||
(immed-info 0 0) ;delete page
|
||
(immed-info 0 -1) ;from myself
|
||
(setz 0 tt) ;just 1 page, found in tt
|
||
|
||
do-cortyp
|
||
(*call 0 cortyp-request)
|
||
(*lose)
|
||
(jrst 0 fix1)
|
||
cortyp-request
|
||
(setz)
|
||
(sixbit |CORTYP|)
|
||
(0 0 @ a)
|
||
((setz get-info) 0 tt)
|
||
|
||
dsk-sharedp-init
|
||
(move tt (% SQUOZE 0 L))
|
||
(*eval tt)
|
||
(*lose)
|
||
(*suset 0 (% 0 0 t *ruind)) ;Get our user index
|
||
(imuli tt 0 t)
|
||
(move t (% squoze 0 UPGCP))
|
||
(*eval t) ;get address of first page map
|
||
(*lose)
|
||
(addi tt 0 t) ;get address of our page map
|
||
(jsp t fxcons) ; circular links
|
||
(movem A (special *OUR-PAGE-MAP-ADDRESS))
|
||
(move tt (% squoze 0 MMPEAD))
|
||
(*eval tt)
|
||
(*lose)
|
||
(movss 0 tt)
|
||
(hrri tt tt)
|
||
(*getloc tt) ;get contents of mmpead
|
||
(jsp t fxcons)
|
||
(movem a (special *ITS-VAL-MMPEAD))
|
||
(movei a 'T)
|
||
(popj p)
|
||
|
||
dsk-sharedp
|
||
(move tt @ (special *OUR-PAGE-MAP-ADDRESS))
|
||
(move t 0 a) ;get page number
|
||
(rot t -1) ;get offset into page table
|
||
(addi tt 0 t) ;get location of page circular links table
|
||
(movss 0 tt) ;address from which to fetch in left half
|
||
(hrri tt tt) ;get result in TT
|
||
(*getloc tt) ;get word
|
||
(skipl 0 t) ;is our index even?
|
||
(movss 0 tt) ;we want the other (left) half
|
||
(trzn tt 400000) ;is it an MMP/MEMPNT entry?
|
||
(jrst 0 yes-on-dsk) ; nope, probably not on disk
|
||
(trze tt 200000) ;Is it a MEMPNT entry?
|
||
(jrst 0 yes-on-dsk) ; Yes, I don't know what to do with these..
|
||
(add tt @ (special *ITS-VAL-MMPEAD)) ;index into mmp table
|
||
(aos 0 tt) ;we want the second word
|
||
(movss 0 tt) ;getloc wants absolute address in LH
|
||
(hrri tt tt) ;we want the result in TT
|
||
(*getloc tt) ;get the MMP second word
|
||
(hrrzs 0 tt) ;we just look at the right half
|
||
(jumpn tt yes-on-dsk) ;not on disk, not in shared-page hash table
|
||
ret-nil
|
||
(tdza a a) ;Ha, it's shareable
|
||
yes-on-dsk
|
||
(movei a 'T)
|
||
(popj p)
|
||
|
||
who-bore-me?
|
||
(movei tt 1 flp)
|
||
(hrli tt **rlfi)
|
||
(jsp t (/0*0PUSH -4))
|
||
(*break 10. tt)
|
||
(pushj p take2)
|
||
(push p 1)
|
||
(pushj p take2)
|
||
(pop p 2)
|
||
(jcall 2 'CONS)
|
||
take2
|
||
(pop flp tt)
|
||
(pushj p sixatm)
|
||
(call 1 'NCONS)
|
||
(push p 1)
|
||
(pop flp tt)
|
||
(pushj p sixatm)
|
||
(pop p 2)
|
||
(jcall 2 'CONS)
|
||
|
||
(entry fetch-file-page/| subr)
|
||
(move d ttsar b)
|
||
(hrrz d f*chan d)
|
||
(*call 0 fetch-request)
|
||
(jrst 0 fix1)
|
||
(jrst 0 ret-nil)
|
||
fetch-request
|
||
(setz)
|
||
(sixbit |CORBLK|)
|
||
(immed-info 0 1_12.) ;Control - Fail if can't find page
|
||
(immed-info 0 -1) ;from myself
|
||
(0 0 @ a) ;just 1 page into core
|
||
(0 0 d) ;dsk channl number
|
||
(0 0 @ c) ;just 1 page from file
|
||
((setz get-error) 0 tt)
|
||
|
||
()
|
||
|
||
))
|
||
|
||
|
||
(or (get 'BLTARRAY 'VERSION) (load '((LISP) BLTARRAY FASL)))
|
||
(putprop 'PURE-SUSPEND (lsh bporg -10.) 'BPEND)
|
||
|
||
|
||
|
||
(lap-a-list '((lap DEPURIFY-SYMBOL subr)
|
||
(args DEPURIFY-SYMBOL (() . 1))
|
||
(hlrz t 0 A)
|
||
(jsp r skipit?) ;Is the SY2 block marked pure?
|
||
(hrrz t 1 t)
|
||
(jsp r skipit?) ; or is the pname-list pure?
|
||
(hlrz t 0 t)
|
||
(jsp r skipit?) ; or even a pname-word pure?
|
||
(movei A '() )
|
||
(popj p)
|
||
skipit?
|
||
(move tt t) ;If item is pure, then copy it
|
||
(lsh tt -11)
|
||
(move tt ST tt)
|
||
(tlnn tt 40) ; unlesss it is alread pure
|
||
(jrst 0 0 R)
|
||
copyit
|
||
(push p a) ;save original symbol
|
||
(hlrz t 0 A)
|
||
(hrrz t 1 t)
|
||
(push p t) ;ptr to pname list
|
||
(setz a)
|
||
loop
|
||
(skipn t @ 0 P) ;depurify the pname list
|
||
(jrst 0 goon)
|
||
(move b a)
|
||
(hlrz a t)
|
||
(hrrzm t 0 P)
|
||
(jsp t fxnv1)
|
||
(jsp t fwcons)
|
||
(call 2 'CONS)
|
||
(jrst 0 loop)
|
||
goon
|
||
(call 1 'NREVERSE)
|
||
(sub p (% 0 0 1 1))
|
||
(movei b '() )
|
||
(call 2 'PNPUT) ;really only interested in sy2 block
|
||
(move b a)
|
||
(pop p a) ;original symbol
|
||
(hlrz r 0 b) ;addr of new sy2 block
|
||
(hlrz d 0 a) ;addr of old sy2 block
|
||
(move t 0 d)
|
||
(tlo t 300) ;CCN bits etc.
|
||
(movem t 0 r) ;transfer first word of sy2-block
|
||
(move t 1 d)
|
||
(hllm t 1 r) ;transfer args property
|
||
(hrlm r 0 a) ;clobber in new sy2 block
|
||
(popj p)
|
||
() ))
|
||
|
||
|
||
;;;; ANNOUNCE-&-LOAD-INIT-FILE
|
||
|
||
;; Note that as a global variable, ANNOUNCE-&-LOAD-INIT-FILE holds
|
||
;; the lisp version number as returned by (STATUS LISPV)
|
||
; (program-name &optional jcl-line fix-file)
|
||
; "program-name" is the name of the program to be announced.
|
||
; It should have a VERSION property. It will also be used
|
||
; as the FN2 of the (default) init file to be loaded.
|
||
; JCL-LINE should be () or a line of JCL to be parsed as a file
|
||
; to use instead of the normal init file.
|
||
; FIX-FILE is a file of fixes to be loaded at startup time, just
|
||
; before loading the init file.
|
||
; This function is grossly hacked to fit in the small amount of
|
||
; core we have on this page.
|
||
|
||
(defun ANNOUNCE-&-LOAD-INIT-FILE n
|
||
(and
|
||
(not (= n 0))
|
||
(let ((INFILE 'T)
|
||
(ERRSET)
|
||
(opsys (status OPSYS))
|
||
(name (arg 1) )
|
||
jclp usn uid ofile file fix-file )
|
||
(setq DEFAULTF `((,(cond ((eq opsys 'TOPS-20) 'PS) ('DSK))
|
||
,(status UDIR))
|
||
*
|
||
,(cond ((eq opsys 'ITS) '>)
|
||
('T 'LSP))))
|
||
(terpri)
|
||
(princ name)
|
||
(cond ((setq uid (get name 'VERSION))
|
||
(princ '| |)
|
||
(princ uid)))
|
||
(princ '#.(maknam (nconc (exploden '| (in SHARABLE | )
|
||
(exploden (get 'SHARABLE 'C-VERSION))
|
||
(exploden '|, LISP |))))
|
||
(princ ANNOUNCE-&-LOAD-INIT-FILE)
|
||
(tyo #/) )
|
||
(terpri)
|
||
(and (> n 2) (setq fix-file (arg 3)))
|
||
(cond ((and fix-file (setq fix-file (probef fix-file)))
|
||
(terpri)
|
||
(princ '|;Loading FIX file |)
|
||
(prin1 (namestring fix-file))
|
||
(let (FASLOAD) (load fix-file))
|
||
(terpri) ))
|
||
(setq jclp (and (> n 1) (arg 2))
|
||
usn (cond ((status status HOMED) (status HOMED))
|
||
((status UDIR)))
|
||
uid (cond (jclp (maknam (nreverse (cdr (reverse jclp)))))
|
||
((status USERID)))
|
||
ofile (mergef uid `((DSK ,usn) * ,name))
|
||
file (probef ofile))
|
||
(cond ((cond (file (setq uid (cadr ofile)) 'T)
|
||
((eq opsys 'ITS)
|
||
(rplaca (cdr ofile) '*)
|
||
(setq uid usn)
|
||
(progn
|
||
(setq jclp () )
|
||
(errset
|
||
(let ((tfile (open ofile '(NODEFAULT))))
|
||
(setq file (truename tfile))
|
||
(and (not (eq (cadr file) '*))
|
||
(setq uid (cadr file)))
|
||
(close tfile)
|
||
(setq jclp 'T))
|
||
() )
|
||
jclp)))
|
||
(princ '|/îLoading |)
|
||
(princ name)
|
||
(princ '| INIT file for |)
|
||
(princ uid)
|
||
(terpri)
|
||
(and (atom (errset (load file)))
|
||
(princ '| **** Errors while loading|)))
|
||
('T (setq file () )))
|
||
'*)))
|
||
|
||
|
||
|
||
|
||
(eval-when (load)
|
||
(prog (*rset file-page-table file-namelist x y)
|
||
; set up shared pages table
|
||
(declare (fixnum page-number n i x))
|
||
(setq file-page-table (array () FIXNUM 256.)
|
||
COMMUNIZE-FILE-ARRAY (open (|+internal-call/|| () 'FILE)
|
||
'(IN FIXNUM SINGLE))
|
||
file-namelist (truename COMMUNIZE-FILE-ARRAY))
|
||
(cond ((cond ((not (= (in COMMUNIZE-FILE-ARRAY) 0)) (setq y () ) 'T)
|
||
((or (not (memq (cadr file-namelist) '(PURQIO PURQIX)))
|
||
(not (eq (caddr file-namelist) ANNOUNCE-&-LOAD-INIT-FILE)))
|
||
(setq y 'T)
|
||
'T))
|
||
(princ '|/îFile | msgfiles)
|
||
(prin1 (namestring file-namelist) msgfiles)
|
||
(princ '| is not this pdump'd LISP file| msgfiles)
|
||
(cond ((null y) (error '|LISP| COMMUNIZE-FILE-ARRAY))
|
||
('t (princ '|/îThis has been only a courtesy warning message/î|
|
||
msgfiles)))))
|
||
(fillarray file-page-table COMMUNIZE-FILE-ARRAY)
|
||
(close COMMUNIZE-FILE-ARRAY)
|
||
(setq y (array () FIXNUM 32.))
|
||
(unwind-protect
|
||
(do ((page-number 0 (1+ page-number))
|
||
(i 0 (+ i 4))
|
||
(x 0) (n 0) )
|
||
((= page-number 256.)
|
||
(mapc 'DEPURIFY-SYMBOL
|
||
(setq DEPURIFY-SYMBOL
|
||
(append (car file-namelist)
|
||
(cdr file-namelist)
|
||
'(COMMUNIZE-SINGLE-FILE COMMMUNIZE-FILE-ARRAY
|
||
CORBLK DSK |:PDUMPED/î| ))))
|
||
; Success!
|
||
(setq |+internal-page-map/|| y))
|
||
(setq x (arraycall FIXNUM file-page-table page-number))
|
||
(cond ((and (plusp x) (= (logand 3 (lsh x -16.)) 01))
|
||
; LISP system pure pages, which LISP itself
|
||
; will cut out during a suspend
|
||
(setq n (+ n (lsh 1_1 i)))))
|
||
(cond ((= i 28.)
|
||
(store (arraycall FIXNUM y (// page-number 8.)) n)
|
||
(setq i -4 n 0))) )))
|
||
)
|
||
|