root/trunk/lisp/sys/coldut.lisp @ 292

Revision 227, 46.8 KB (checked in by rjs, 3 years ago)

Update.

Line 
1; -*- Mode:Lisp; Package:Cold; Lowercase:T; Base:8 -*-
2;       ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4; Utilities for cold-load generator
5
6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7;;; To compile this:                           ;;;
8;;;   (1) Load the old QFASL of it             ;;;
9;;;   (2) Run (LOAD-PARAMETERS)                ;;;
10;;;   (3) Now you may compile it               ;;;
11;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12
13;;; Little variables that have to do with the word format
14(defvar big-fixnum)
15(defvar little-fixnum)
16(defvar q-typed-pointer-mask)   ;Due to deficiencies in LDB and DPB
17(defvar q-pointer-mask)
18
19;;; The virtual memory
20
21(defvar n-vmem-pages 16.)
22
23;(i,0) is virtual page number, (i,1) is rqb
24;Both slots are nil if unused
25(defvar vmem-pages (make-array nil 'art-q (list n-vmem-pages 2)))
26
27(defvar vmem-page-reuse-pointer)
28
29(defvar vmem-part-base)
30(defvar vmem-part-size)
31
32(defun vmem-initialize (part-name)
33  (setq vmem-page-reuse-pointer 0)
34  (multiple-value (vmem-part-base vmem-part-size) (sys:find-disk-partition part-name))
35  (or vmem-part-base (ferror nil "~S partition not found on disk unit 0" part-name))
36  (dotimes (i n-vmem-pages)
37    (aset nil vmem-pages i 0)
38    (aset nil vmem-pages i 1)))
39
40;Write out all the buffered pages and return the rqb's
41(defun vmem-finish (&aux rqb)
42  (dotimes (i n-vmem-pages)
43    (cond ((setq rqb (aref vmem-pages i 1))
44           (vmem-disk-io rqb (aref vmem-pages i 0) t)
45           (sys:return-disk-rqb rqb)
46           (aset nil vmem-pages i 1)))))
47
48(defun vmem-disk-io (rqb vpn writep)
49  (and (or (minusp vpn) ( vpn vmem-part-size))
50       (ferror nil "Disk i//o outside of partition"))
51  (funcall (if writep #'sys:disk-write #'sys:disk-read) rqb 0 (+ vpn vmem-part-base)))
52
53;Given address returns art-16b array containing that page.  With second arg of nil
54;initializes to dtp-free instead of reading in from disk.
55(defun vmem-find-page (address &optional (get-from-disk-p t))
56  (do ((i 0 (1+ i))
57       (vpn (// ;(ldb sym:%%q-pointer address)
58                (logand q-pointer-mask address)
59                sym:page-size))
60       (rqb) (buf) (tem))
61      (( i n-vmem-pages)
62       (setq i vmem-page-reuse-pointer)
63       (cond ((setq rqb (aref vmem-pages i 1))
64              (vmem-disk-io rqb (aref vmem-pages i 0) t))       ;Swap this guy out
65             (t (setq rqb (sys:get-disk-rqb))
66                (aset rqb vmem-pages i 1)))
67       (aset vpn vmem-pages i 0)
68       (setq buf (sys:rqb-buffer rqb))
69       (cond (get-from-disk-p
70               (vmem-disk-io rqb vpn nil))
71             (t (setq tem (dpb sym:dtp-free sym:%%q-data-type (* vpn sym:page-size)))
72                (do ((j 0 (1+ j))
73                     (high (ldb 2020 tem))
74                     (low (ldb 0020 tem)))
75                    (( j sym:page-size))
76                  (aset (+ low j) buf (+ j j))
77                  (aset high buf (+ j j 1)))))
78       buf)
79    (cond ((eq (aref vmem-pages i 0) vpn)       ;Already swapped in
80           (and (= vmem-page-reuse-pointer i)
81                (setq vmem-page-reuse-pointer (\ (1+ i) n-vmem-pages)))
82           (return (sys:rqb-buffer (aref vmem-pages i 1)))))))
83
84(defun vread (address)
85  (let ((buf (vmem-find-page address))
86        (i (* 2 (\ address sym:page-size))))
87    (dpb (aref buf (1+ i)) 2020 (aref buf i))))
88
89(defun vwrite (address value)
90  (let ((buf (vmem-find-page address))
91        (i (* 2 (\ address sym:page-size))))
92    (aset (ldb 0020 value) buf i)
93    (aset (ldb 2020 value) buf (1+ i))))
94
95(defun vcontents (address)
96  (logand q-typed-pointer-mask (vread address)))
97
98(defun vcdr-code (address)
99  (ldb sym:%%q-cdr-code (vread address)))
100
101(defun vflag-bit (address)
102  (ldb sym:%%q-flag-bit (vread address)))
103
104(defun vstore-contents (address value)
105  (let ((buf (vmem-find-page address))
106        (i (* 2 (\ address sym:page-size))))
107    (aset (ldb 0020 value) buf i)
108    (aset (deposit-field (aref buf (1+ i))
109                         (- sym:%%q-all-but-typed-pointer 2000)
110                         (ldb 2020 value))
111          buf (1+ i))))
112
113(defun vstore-cdr-code (address value)
114  (let ((buf (vmem-find-page address))
115        (i (* 2 (\ address sym:page-size))))
116    (aset (dpb value (- sym:%%q-cdr-code 2000) (aref buf (1+ i))) buf (1+ i))))
117
118(defun vstore-flag-bit (address value)
119  (let ((buf (vmem-find-page address))
120        (i (* 2 (\ address sym:page-size))))
121    (aset (dpb value (- sym:%%q-flag-bit 2000) (aref buf (1+ i))) buf (1+ i))))
122
123(defun vwrite-cdr (address cdr-code value)
124  (vwrite address (dpb cdr-code sym:%%q-cdr-code value)))
125
126(defsubst vmake-pointer (data-type address)
127  (dpb data-type sym:%%q-all-but-pointer address))
128
129(defsubst vdata-type (value)
130  (ldb sym:%%q-data-type value))
131
132(defsubst vfix (value)
133  (vmake-pointer sym:dtp-fix value))
134
135(defvar sym-package (pkg-find-package "cold-symbols"))
136(defvar misc-function-list)
137(defvar misc-instruction-list)
138
139;;; Set up the sym: package by loading the appropriate files
140(defun load-parameters ()
141  (load "ai:lispm;qcom >" sym-package)
142  (load "ai:lispm;qdefs >" sym-package)
143  (setq misc-function-list nil)
144  (setq misc-instruction-list nil)
145  (load "ai:lispm;defmic >" sym-package)
146  (dolist (l sym:system-constant-lists) ;Make declarations so can compile self
147    (dolist (s (symeval l))
148      (putprop s t 'special)))
149  (setq big-fixnum (dpb -1 (1- sym:%%q-pointer) 0)
150        little-fixnum (1- (- big-fixnum))
151        q-typed-pointer-mask (1- (ash 1 sym:%%q-typed-pointer))
152        q-pointer-mask (1- (ash 1 sym:%%q-pointer)))) 
153
154;These have to be explicitly declared special because they only exist in
155;the cold-load generator, and are not sent over.
156(declare (special sym:rm-area-sizes sym:scratch-pad-pointers sym:scratch-pad-parameters
157                  sym:scratch-pad-parameter-offset sym:q-corresponding-variable-lists
158                  sym:support-vector-contents sym:constants-page
159                  sym:read-only-area-list sym:wired-area-list sym:pdl-buffer-area-list
160                  sym:list-structured-areas sym:static-areas
161                  sym:prin1 sym:base sym:ibase sym:*nopoint sym:for-cadr))
162
163;Put on QLVAL and QINTCMP properties
164;Creates MISC-FUNCTION-LIST for STORE-MISC-LINK  (CALLED FROM STORE-MISC-U-ENTRY-LINKS)
165; and MISC-INSTRUCTION-LIST for STORE-MICRO-CODE-SYMBOL-NAMES
166(defun defmic (&quote name opcode arglist lisp-function-p &optional no-qintcmp)
167  (prog (function-name instruction-name)
168    (cond ((atom name)
169           (setq function-name name instruction-name name))
170          ((setq function-name (car name) instruction-name (cdr name))))
171    (cond ((not no-qintcmp)
172           (putprop instruction-name (length arglist) 'sym:qintcmp)
173           (or (eq function-name instruction-name)
174               (putprop function-name (length arglist) 'sym:qintcmp)))
175          (t ;The number of arguments is needed anyway for the cold-load generator
176           (putprop instruction-name (length arglist) 'qintcmp-kludge)
177           (or (eq function-name instruction-name)
178               (putprop function-name (length arglist) 'qintcmp-kludge))))
179    (putprop instruction-name opcode 'sym:qlval)
180    (setq misc-instruction-list (cons instruction-name misc-instruction-list))
181    (and lisp-function-p
182         (setq misc-function-list (cons name misc-function-list)))))
183
184;;; Basic area-processing and data-storing stuff
185
186;Note that area names are always symbols in the sym: package
187
188(defvar symbol-creation-trace-list nil)
189(defvar qnil)
190(defvar qtruth)
191(defvar area-origins (make-array nil 'art-q 400))
192(defvar area-alloc-pointers (make-array nil 'art-q 400))
193(defvar area-alloc-bounds (make-array nil 'art-q 400))
194
195(defvar area-corresponding-arrays
196        'sym:(area-name region-origin region-length region-free-pointer
197              region-gc-pointer region-bits area-region-list area-region-size
198              area-maximum-size region-list-thread))
199
200(defvar micro-code-entry-corresponding-arrays
201        'sym:(constants-area micro-code-entry-area
202              micro-code-entry-name-area micro-code-entry-args-info-area
203              micro-code-entry-arglist-area micro-code-exit-area
204              micro-code-entry-max-pdl-usage micro-code-symbol-area
205              micro-code-symbol-name-area support-entry-vector))
206
207(defvar areas-with-fill-pointers
208        (append area-corresponding-arrays micro-code-entry-corresponding-arrays))
209
210 ;areas in this list get art-q-list
211(defvar list-referenced-areas areas-with-fill-pointers)
212
213 ;areas in this list get art-q, all other areas get art-32b
214(defvar array-referenced-areas 'sym:(system-communication-area page-table-area
215                                     region-sorted-by-origin))
216
217(defun create-areas (&aux high-loc)
218  (do l sym:rm-area-sizes (cddr l) (null l)     ;Area sizes in pages
219    (putprop (car l) (cadr l) 'area-size))
220  (fillarray area-origins '(nil))
221  ;; Set up the area origin and allocation tables
222  (do ((l sym:area-list (cdr l))
223       (i 0 (1+ i))
224       (loc 0 (+ loc (* (get-area-size (car l)) sym:page-size))))
225      ((null l) (setq high-loc loc))
226    (aset loc area-origins i))
227  (copy-array-contents area-origins area-alloc-pointers)
228  (copy-array-portion area-origins 1 400 area-alloc-bounds 0 400)
229  (aset high-loc area-alloc-bounds (1- (length sym:area-list)))
230  ;; Fill various areas with default stuff
231  (init-area-contents 'sym:area-region-size (vfix 40000))
232  (init-area-contents 'sym:area-maximum-size (vfix big-fixnum))
233  (init-area-contents 'sym:region-origin (vfix 0))  ;so good type in free region#'s
234  (init-area-contents 'sym:region-length (vfix 0))  ;..
235  (init-area-contents 'sym:region-free-pointer (vfix 0))
236  (init-area-contents 'sym:region-gc-pointer (vfix 0))
237  (init-area-contents 'sym:region-bits (vfix 0))  ;Suitable for free region
238  ;; Set up contents of certain initial areas
239  (do ((i 0 (1+ i))
240       (al sym:area-list (cdr al))
241       (fixed-p t))
242      ((null al))
243    (and (eq (car al) 'sym:working-storage-area) (setq fixed-p nil))
244    (vwrite (+ (get-area-origin 'sym:area-region-list) i) (vfix i))
245    (vwrite (+ (get-area-origin 'sym:region-list-thread) i) (vfix (+ i little-fixnum)))
246    (vwrite (+ (get-area-origin 'sym:region-bits) i)
247            (vfix (+ (dpb (cond ((memq (car al) sym:read-only-area-list) 1200)  ;ro
248                                ((memq (car al) sym:wired-area-list) 1400)      ;rw
249                                ((memq (car al) sym:pdl-buffer-area-list)
250                                 500)                   ;may be in pdl-buffer, no access.
251                                (t 1300))                       ;rwf
252                          sym:%%region-map-bits
253                          0)
254                     (dpb 1 sym:%%region-oldspace-meta-bit 0)
255                     (dpb (if (eq (car al) 'sym:extra-pdl-area) 0 1)
256                          sym:%%region-extra-pdl-meta-bit 0)
257                     (dpb (if (memq (car al) sym:list-structured-areas) 0 1)
258                          sym:%%region-representation-type 0)
259                     (dpb (cond ((eq (car al) 'sym:extra-pdl-area)
260                                 sym:%region-space-extra-pdl)
261                                (fixed-p sym:%region-space-fixed)
262                                ((memq (car al) sym:static-areas) sym:%region-space-static)
263                                (t sym:%region-space-new))
264                          sym:%%region-space-type 0))))
265    (vwrite (+ (get-area-origin 'sym:region-origin) i)
266            (vfix (aref area-origins i)))
267    (vwrite (+ (get-area-origin 'sym:region-length) i)
268            (vfix (- (aref area-alloc-bounds i) (aref area-origins i))))))
269
270(defun get-area-number (area)
271  (cond ((numberp area) area)
272        ((find-position-in-list area sym:area-list))    ;symeval??
273        ((ferror nil "~S bad area-name" area))))
274
275(defun get-area-origin (area)
276  (aref area-origins (get-area-number area)))
277
278(defun allocate-block (area size &aux address high)
279  (setq area (get-area-number area))
280  (setq address (aref area-alloc-pointers area))
281  (setq high (+ address size))
282  (and (> high (aref area-alloc-bounds area))
283       (ferror nil "~A area overflow" (nth area sym:area-list)))
284  (aset high area-alloc-pointers area)
285  ;Page in all the fresh pages without really paging them in, thus initializing them
286  (do ((vpn (// (+ address sym:page-size -1) sym:page-size) (1+ vpn))
287       (hpn (// (+ high sym:page-size -1) sym:page-size)))
288      (( vpn hpn))
289    (vmem-find-page (* vpn sym:page-size) nil))
290  address)
291
292;In pages
293(defun get-area-size (area)
294  (check-arg area (memq area sym:area-list) "an area-name")
295  (cond ((eq area 'sym:free-area) 0)
296        ((get area 'area-size))
297        (t 1)))
298
299;Doesn't advance allocation pointer, i.e. sets it back to origin when done
300(defun init-area-contents (area contents)
301  (let ((count (* sym:page-size (get-area-size area))))
302    (setq area (get-area-number area))
303    (do ((adr (allocate-block area count) (1+ adr))
304         (n count (1- n)))
305        ((zerop n)
306         (store-nxtnil-cdr-code area)
307         (aset (aref area-origins area) area-alloc-pointers area))
308      (vwrite-cdr adr sym:cdr-next contents))))
309
310(defvar store-halfwords-address)
311(defvar store-halfwords-count)
312(defvar store-halfwords-buffer)
313
314(defun begin-store-halfwords (area-name n-words)
315  (let* ((area-number (get-area-number area-name))
316         (address (allocate-block area-number n-words)))
317    (setq store-halfwords-address address
318          store-halfwords-count (* 2 n-words))
319    address))
320
321(defun store-halfword (hwd)
322  (if (oddp (setq store-halfwords-count (1- store-halfwords-count)))
323      (setq store-halfwords-buffer hwd)
324      (vwrite store-halfwords-address (dpb hwd 2020 store-halfwords-buffer))
325      (setq store-halfwords-address (1+ store-halfwords-address))))
326
327(defun end-store-halfwords ()
328  (or (zerop store-halfwords-count)
329      (ferror nil "store-halfword called wrong number of times")))
330
331(defun make-q-list (area s-exp &aux bsize value)
332  (cond ((numberp s-exp)
333         (cond ((small-floatp s-exp) (make-small-flonum s-exp))
334               ((floatp s-exp) (store-flonum area s-exp))
335               ((and ( s-exp big-fixnum) ( s-exp little-fixnum)) (vfix s-exp))
336               (t (store-bignum area s-exp))))
337        ((symbolp s-exp) (qintern s-exp))
338        ((stringp s-exp) (store-string 'sym:p-n-string s-exp))
339        ((atom s-exp) (ferror nil "~S unknown type" s-exp))
340        (t (or (memq area sym:list-structured-areas)
341               (ferror nil "make-q-list in non-list-structured area ~S" area))
342           (setq bsize (length s-exp))
343           (cond ((cdr (last s-exp)) (setq bsize (1+ bsize))))  ;ends in dotted pair
344           (setq value (vmake-pointer sym:dtp-list (allocate-block area bsize)))
345           (do ((s-exp s-exp (cdr s-exp))
346                (adr (logand q-pointer-mask value) (1+ adr))
347                (c-code))
348               ((atom s-exp)
349                (or (null s-exp)
350                    (vwrite-cdr adr sym:cdr-error (make-q-list area s-exp))))
351             (setq c-code (cond ((null (cdr s-exp)) sym:cdr-nil)
352                                ((atom (cdr s-exp)) sym:cdr-normal)
353                                (t sym:cdr-next)))
354             (vwrite-cdr adr c-code (make-q-list area (car s-exp))))
355           value)))
356
357(defun make-small-flonum (s-exp)  ;I hope the format doesn't change!
358  (vmake-pointer sym:dtp-small-flonum (%pointer s-exp)))
359
360(defun magic-aref (a i n)
361  (if (< i n) (aref a i) 200))
362
363(defun store-string (area string)
364   (and (memq area sym:list-structured-areas)
365        (ferror nil "store-string in list-structured area"))
366   (let* ((n-chars (string-length string))
367          (n-words (+ 1 (// (+ n-chars 3) 4)))
368          (adr (allocate-block area n-words)))
369     (and (> n-chars sym:%array-max-short-index-length)
370          (ferror nil "I don't know how to make a long-array"))
371     (vwrite adr (vmake-pointer sym:dtp-array-header
372                                (+ sym:array-dim-mult   ;1-dim
373                                   sym:art-string
374                                   n-chars)))
375     (do ((i 1 (1+ i))
376          (j 0 (+ j 4)))
377         ((= i n-words))
378       (vwrite (+ adr i)
379               (+ (magic-aref string j n-chars)
380                  (ash (magic-aref string (1+ j) n-chars) 8)
381                  (ash (magic-aref string (+ j 2) n-chars) 16.)
382                  (ash (magic-aref string (+ j 3) n-chars) 24.))))
383     (vmake-pointer sym:dtp-array-pointer adr)))
384
385(defun store-symbol-vector (atom-name area)
386  (and (memq area sym:list-structured-areas)
387       (ferror nil "store-symbol-vector in list-structured area ~S" area))
388  (and (eq atom-name '**screw**)
389       (ferror nil "you've probably encountered a bug in froid (coldld)" atom-name))
390  (prog (adr sym path real-atom-name package-name pname)
391     (cond ((setq path (get atom-name 'package-path))
392            (or (= (length path) 2)
393                (ferror nil "package path ~S not 2 long - code not hairy enough"))
394            (setq package-name (qintern (car path))
395                  real-atom-name (car (last path))))
396           (t (setq package-name qnil real-atom-name atom-name)))
397     (cond (symbol-creation-trace-list  ;debugging tool to track down appears twice in
398             (do ((l symbol-creation-trace-list (cdr l)))  ;cold load messages.
399                 ((null l))
400               (cond ((inhibit-style-warnings
401                        (samepnamep real-atom-name (car l)))
402                      (print (list 'a-flavor-of real-atom-name 'being-created
403                                   'atom-name atom-name 'path path
404                                   'package-name package-name)))))))
405     (setq pname (store-string 'sym:p-n-string (string real-atom-name)))
406     (setq adr (allocate-block area sym:length-of-atom-head))
407     (vwrite-cdr adr sym:cdr-next (vmake-pointer sym:dtp-symbol-header pname))
408     (vwrite-cdr (+ adr 1) sym:cdr-next (vmake-pointer sym:dtp-null adr))
409     (vwrite-cdr (+ adr 2) sym:cdr-next (vmake-pointer sym:dtp-null adr))
410     (vwrite-cdr (+ adr 3) sym:cdr-next qnil)
411     (vwrite-cdr (+ adr 4) sym:cdr-nil package-name)
412     (setq sym (vmake-pointer sym:dtp-symbol adr))
413     (putprop atom-name sym 'q-atom-head)
414     (return sym)))
415
416;New version of qintern.  Machine builds obarray when it first comes up (easy enough).
417(defun qintern (atom-name)
418    (or (eq (car (package-cell-location atom-name)) sym-package)
419        (setq atom-name (intern (string atom-name) sym-package)))
420    (or (get atom-name 'q-atom-head)
421        (store-symbol-vector atom-name 'sym:nr-sym)))
422
423(defun store-nxtnil-cdr-code (area)
424  (vstore-cdr-code (1- (aref area-alloc-pointers (get-area-number area))) sym:cdr-nil))
425
426(defun store-list-of-atoms (area loa)
427  (let ((adr (allocate-block area (length loa))))
428    (do ((loa loa (cdr loa))
429         (adr adr (1+ adr)))
430        ((null loa))
431      (vwrite-cdr adr (if (null (cdr loa)) sym:cdr-nil sym:cdr-next)
432                      (q-convert-atom (car loa))))
433    adr))
434
435(defun q-convert-atom (atm)
436  (if (numberp atm) (make-q-list nil atm) (qintern atm)))
437
438(defun store-list (area lst)
439  (let ((adr (allocate-block area (length lst))))
440    (do ((lst lst (cdr lst))
441         (adr adr (1+ adr)))
442        ((null lst))
443      (vwrite-cdr adr (if (null (cdr lst)) sym:cdr-nil sym:cdr-next)
444                      (make-q-list 'init-list-area (car lst))))
445    adr))
446
447(defun store-nils (area number)
448  (let ((adr (allocate-block area number)))
449    (do ((number number (1- number))
450         (adr adr (1+ adr)))
451        ((zerop number))
452      (vwrite-cdr adr (if (= number 1) sym:cdr-nil sym:cdr-next) qnil))
453    adr))
454
455(defun storeq (area data)
456  (let ((adr (allocate-block area 1)))
457    (vwrite adr data)
458    adr))
459
460(defun store-cdr-q (area cdr-code data)
461  (let ((adr (allocate-block area 1)))
462    (vwrite-cdr adr cdr-code data)
463    adr))
464
465;;; Hair for making arrays
466
467(defun init-q-array (area name offset type dimlist displaced-p leader)
468  (init-q-array-named-str area name offset type dimlist displaced-p leader nil))
469
470;NOTE!! LEADER IS STOREQ ED DIRECTLY SO IT MUST ALREADY BE MAKE-Q-LIST IFIED
471(defun init-q-array-named-str (area name offset type dimlist displaced-p leader named-str)
472        ;  leader is contents of array leader, if desired.  it is in "storage order"
473        ;which is reversed from index order.
474        ;  if leader is numeric, it means make leader consisting of that many q's
475        ;initialized to nil.
476        ;  if name -> nil, return (list <array-adr> <data-length>) and dont try
477        ;to store in function or value cell.
478        ;offset 1 for storing pointer to array in value cell, 2 for function cell
479  (and (memq area sym:list-structured-areas)
480       (ferror nil "init-q-array in list-structured area"))
481  (prog (tem ndims index-length data-length tem1 leader-length header-q long-array-flag adr)
482        (and (numberp dimlist) (setq dimlist (list dimlist)))
483        (setq ndims (length dimlist))
484        (setq index-length (list-product dimlist))
485        (cond ((and (> index-length sym:%array-max-short-index-length)
486                    (null displaced-p))
487               (setq long-array-flag t)))
488        (setq leader-length (cond ((null leader) 0)
489                                  ((numberp leader) (+ 2 leader))
490                                  (t (+ 2 (length leader)))))
491        (cond ((null (setq tem (assq type sym:array-elements-per-q)))
492               (ferror nil "~S bad array type" type)))
493        (setq tem (cdr tem))
494        (cond ((not (null leader))
495               (setq adr (allocate-block area leader-length))
496               (vwrite adr (vmake-pointer sym:dtp-header
497                                          (dpb sym:%header-type-array-leader
498                                               sym:%%header-type-field
499                                               leader-length)))
500               (cond ((numberp leader)
501                      (dotimes (i leader)
502                        (vwrite (+ adr i 1) qnil))
503                      (and named-str (vwrite (+ adr leader -1)  ;(array-leader x 1)
504                                             (qintern named-str))))
505                     (t (do ((l leader (cdr l))
506                             (i 1 (1+ i)))
507                            ((null l))
508                          (vwrite (+ adr i) (car l)))))
509               (vwrite (+ adr leader-length -1) (vfix (- leader-length 2)))))
510        (setq data-length (// (+ index-length (1- tem)) tem))
511        (setq header-q (vmake-pointer sym:dtp-array-header
512                                      (+ (* sym:array-dim-mult ndims)
513                                         (symeval type))))
514        (and leader (setq header-q (+ header-q sym:array-leader-bit)))
515        (and named-str (setq header-q (+ header-q sym:array-named-structure-flag)))
516        (cond (displaced-p   ;note, no index-offset arrays in cold-load
517                (setq tem 1 header-q (+ header-q sym:array-displaced-bit 2)))
518              ((null long-array-flag)
519                (setq tem 1 header-q (+ header-q index-length)))
520              (t (setq tem 2 header-q (+ header-q sym:array-long-length-flag))))
521        (setq tem1 (setq adr (allocate-block area (+ tem ndims -1))))
522        (vwrite adr header-q)
523        (and (= tem 2) (vwrite (setq adr (1+ adr)) (vfix index-length)))
524        ;Store all dimensions except for last
525        (do l dimlist (cdr l) (null (cdr l))
526          (vwrite (setq adr (1+ adr)) (vfix (car dimlist))))
527        (cond ((null name) (return (list tem1 data-length))))
528        (vstore-contents (+ (qintern name) offset)
529                         (vmake-pointer sym:dtp-array-pointer tem1))
530        (return data-length)))
531
532(defun store-q-array-leader (arrayp idx data)
533  (vwrite (- arrayp (+ 2 idx))                  ;1 for array header, 1 for ldr len
534          data))
535
536;;; Setting up various magic data structures, mostly having to do with the
537;;; microcode and the fixed-areas
538
539(defun store-support-vector (item)
540  (let ((adr (allocate-block 'sym:support-entry-vector 1)))
541    (vwrite-cdr adr sym:cdr-next
542                (cond ((eq (car item) 'sym:function)
543                       (get-q-fctn-cell (cadr item)))
544                      ((eq (car item) 'sym:quote)
545                       (make-q-list 'sym:init-list-area (cadr item)))
546                      (t (ferror nil "bad-support-code: ~S" item))))
547    adr))
548
549(defun get-q-fctn-cell (fctn &aux tem)
550  (and (setq tem (get fctn 'q-atom-head))
551       (vcontents (+ tem 2))))
552
553(defun store-displaced-array-pointer (area)
554 (prog (fillp area-array-type data-length adr)
555    (setq fillp (memq area areas-with-fill-pointers))
556    (setq area-array-type
557          (cond ((memq area list-referenced-areas) 'sym:art-q-list)
558                ((memq area array-referenced-areas) 'sym:art-q)
559                (t 'sym:art-32b)))
560    (setq data-length
561          (init-q-array 'sym:control-tables
562                        area 
563                        2
564                        area-array-type 
565                        (list (* sym:page-size (get-area-size area)))
566                        t
567                        (and fillp
568                             (list (vfix (cond ((memq area area-corresponding-arrays)
569                                                (length area-list))
570                                               ((memq area
571                                                      micro-code-entry-corresponding-arrays)
572                                                (length micro-code-entry-vector))
573                                               (t
574                                                 (* sym:page-size (get-area-size area)))))))))
575    (setq adr (allocate-block 'sym:control-tables 2))
576    (vwrite adr (vfix (get-area-origin area)))
577    (vwrite (1+ adr) (vfix data-length))))
578
579;x is a symbol or cons function-name instruction-name
580(defun store-misc-link (x)
581  (cond ((atom x)
582         (misc-store-micro-entry x x))
583        ((misc-store-micro-entry (car x) (cdr x)))))
584
585;special kludge which filters out *catch
586(defun store-misc-link-1 (x)
587  (or (eq x 'sym:*catch)
588      (store-misc-link x)))
589
590;This creates an indirect through the MICRO-CODE-SYMBOL-AREA by using
591;DTP-FIX and 200 less than the misc function index.  This makes
592;the core image independent of the microcode version.
593(defun misc-store-micro-entry (name me-name)
594  (prog (misc-index u-entry-prop u-entry-index)
595        (cond ((null (setq misc-index (get me-name 'sym:qlval)))
596               (ferror nil "No QLVAL property: ~S" me-name)))
597        (setq u-entry-prop (vfix (- misc-index 200)))
598        (setq u-entry-index (get-u-entry-index name))
599        (vstore-contents (+ (qintern name) 2)   ;function cell
600                         (vmake-pointer sym:dtp-u-entry u-entry-index))
601        (vstore-contents (+ (get-area-origin 'sym:micro-code-entry-area) u-entry-index)
602                         u-entry-prop)
603        (vstore-contents (+ (get-area-origin 'sym:micro-code-entry-args-info-area)
604                            u-entry-index)
605                         (make-q-list 'sym:init-list-area (get-q-args-prop name)))))
606
607;This abbreviated version of the stuff in UTIL2 should be enough to get us off the ground
608(defun get-q-args-prop (fctn &aux tem)
609  (cond ((setq tem (get fctn 'sym:argdesc))
610         (get-q-args-prop-from-argdesc-prop tem))
611        ((setq tem (get fctn 'sym:qintcmp))
612         (+ (lsh tem 6) tem))
613        ;; You may think this is a kludge, but in the Maclisp cold-load generator
614        ;; it gets the number of arguments out of the Maclisp subr of the same name!
615        ((setq tem (get fctn 'qintcmp-kludge))
616         (+ (lsh tem 6) tem))
617        (t (ferror nil "Cannot find arg desc for ~S" fctn))))
618
619(defun get-q-args-prop-from-argdesc-prop (arg-desc)
620  (prog (prop min-args max-args count item)
621        (setq prop 0 min-args 0 max-args 0)
622   l    (cond ((null arg-desc) (return (+ prop (lsh min-args 6) max-args))))
623        (setq count (caar arg-desc))
624        (setq item (cadar arg-desc)) ;list of arg syntax, quote type, other attributes
625        (setq arg-desc (cdr arg-desc))
626   l1   (cond ((= 0 count) (go l))
627              ((memq 'sym:fef-arg-rest item)
628               (setq prop (logior prop (if (or (memq 'sym:fef-qt-eval item)
629                                               (memq 'sym:fef-qt-dontcare item))
630                                           sym:%arg-desc-evaled-rest
631                                           sym:%arg-desc-quoted-rest)))
632               (go l))
633              ((memq 'sym:fef-arg-req item)
634               (setq min-args (1+ min-args)))
635              ((memq 'sym:fef-arg-opt item))
636              (t (go l)))
637        (setq max-args (1+ max-args))
638        (or (memq 'sym:fef-qt-eval item)
639            (memq 'sym:fef-qt-dontcare item)
640            (setq prop (logior prop sym:%arg-desc-fef-quote-hair)))
641        (setq count (1- count))
642        (go l1)))
643
644(defvar micro-code-entry-vector nil)
645
646(defun get-u-entry-index (fctn)
647  (prog (tem)
648        (cond ((setq tem (find-position-in-list fctn micro-code-entry-vector))
649               (return tem)))
650        (setq tem (length micro-code-entry-vector))
651        (store-cdr-q 'sym:micro-code-entry-area sym:cdr-next qnil)  ;will be changed
652        (store-cdr-q 'sym:micro-code-entry-name-area sym:cdr-next (qintern fctn))
653        (store-cdr-q 'sym:micro-code-entry-args-info-area sym:cdr-next qnil)  ;will be chngd
654        (store-cdr-q 'sym:micro-code-entry-arglist-area sym:cdr-next qnil) ;set on startup
655        (setq micro-code-entry-vector (nconc micro-code-entry-vector
656                                             (list fctn)))
657        (return tem)))
658
659(defun store-micro-code-symbol-name (name)
660  (let ((opcode (get name 'sym:qlval)))
661    (or opcode (ferror nil "no qlval property in store-micro-code-symbol-name: ~S" name))
662    (vstore-contents (+ (get-area-origin 'sym:micro-code-symbol-name-area) (- opcode 200))
663                     (qintern name))))
664
665(defun store-lisp-value-list (x)
666  (mapc (function store-lisp-value) (symeval x)))
667
668(defun store-lisp-value (sym)
669  (storein-q-value-cell sym (make-q-list 'sym:init-list-area (symeval sym))))
670
671;Store cdr-coded list of 1000 NIL's.
672(defun init-micro-code-symbol-name-area ()
673  (store-nils 'sym:micro-code-symbol-name-area 1000))
674
675(defun cold-load-time-setq (pair-list &aux var value)
676  (do pair-list pair-list (cddr pair-list) (null pair-list)
677    (setq var (car pair-list) value (cadr pair-list))
678    (cond ((and (atom value) (or (numberp value)
679                                 (stringp value)
680                                 (memq value '(sym:t sym:nil)))))
681          ((eq (car value) 'sym:quote)
682           (setq value (cadr value)))
683          (t (ferror nil "(setq ~S ~S) no can do" var value)))
684    (storein-q-value-cell var (make-q-list 'sym:init-list-area value))))
685
686(defun storein-q-value-cell (sym data)
687  (vstore-contents (1+ (qintern sym)) data))
688
689(defun store-constant (c)
690  (vwrite-cdr (allocate-block 'sym:constants-area 1)
691              sym:cdr-next
692              (make-q-list 'sym:init-list-area c)))
693
694(defun init-scratch-pad-area ()
695  (init-area-contents 'sym:scratch-pad-init-area (vfix 0))
696  (scratch-store-q 'sym:initial-top-level-function
697                   (vmake-pointer sym:dtp-locative
698                                  (+ (qintern 'sym:lisp-top-level) 2)))
699  ;trap-handler (not used)
700  (let ((initial-stack-group-pointer (make-initial-stack-group-structure)))
701    (scratch-store-q 'sym:current-stack-group initial-stack-group-pointer)
702    (scratch-store-q 'sym:initial-stack-group initial-stack-group-pointer))
703  (scratch-store-q 'sym:error-handler-stack-group qnil)  ;initialized at run time
704  (scratch-store-q 'sym:default-cons-area (vfix (get-area-number 'sym:working-storage-area))))
705
706(defun scratch-store-q (symbolic-name data)
707   (prog (tem origin)
708      (setq origin (get-area-origin 'sym:scratch-pad-init-area))
709      (cond ((setq tem (find-position-in-list symbolic-name sym:scratch-pad-pointers))
710             (vstore-contents (+ origin tem) data))
711            ((setq tem (find-position-in-list symbolic-name sym:scratch-pad-parameters))
712             (vstore-contents (+ origin sym:scratch-pad-parameter-offset tem) data))
713            (t (ferror nil "unknown-scratch-quantity: ~S" symbolic-name)))))
714
715(defun store-a-mem-location-names ()
716    (do ((name sym:a-memory-location-names (cdr name))
717         (locn (+ 40 sym:a-memory-virtual-address) (1+ locn)))
718        ((null name))
719     (store-mem-location (car name) locn))
720    (do name sym:m-memory-location-names (cdr name) (null name)
721     (store-mem-location (car name) (get (car name) 'sym:forwarding-virtual-address))))
722
723(defun store-mem-location (name locn)
724  (storein-q-value-cell name (vmake-pointer sym:dtp-one-q-forward locn)))
725
726(defun make-ordered-array-list (assoc-list)
727  (mapcar (function (lambda (x) (cdr (assq x assoc-list))))
728          sym:array-types))
729
730;The order store-misc-link is called determines the final micro-code-entry
731; numbers that are assigned.  however, except for 0 which must be *catch,
732; micro-code-entry numbers are unconstrained and independant from everything
733; else.  So the other entries below may be in any order.
734(defun store-misc-u-entry-links ()
735  (store-misc-link 'sym:*catch)         ;must be first
736  (mapc (function store-misc-link-1) misc-function-list)
737  ;; now set up the first 600 locations of micro-code-symbol-name-area
738  (init-micro-code-symbol-name-area)
739  (mapc (function store-micro-code-symbol-name) misc-instruction-list))
740
741(defun make-initial-stack-group-structure ()
742  (make-stack-group-structure 'sym:main-stack-group 'sym:control-tables
743                              'sym:linear-pdl-area 'sym:linear-bind-pdl-area
744                              sym:sg-state-active))
745 
746(defun make-stack-group-structure (name sg-area linear-area l-b-p-area initial-state)
747  (prog (sg pdl-array l-b-p-array reg-len spec-len)
748        (setq sg (car (init-q-array sg-area nil nil 'sym:art-stack-group-head '(0)
749                                    nil (length sym:stack-group-head-leader-qs))))
750        (setq pdl-array
751              (car (init-q-array linear-area nil nil 'sym:art-reg-pdl
752                             (list (setq reg-len (- (* sym:page-size
753                                                       (get-area-size 'sym:linear-pdl-area))
754                                                    (+ (length sym:reg-pdl-leader-qs) 4))))
755                        ;4: leader header + leader-length-q + array-header-q + long-length-q
756                             nil (length sym:reg-pdl-leader-qs))))
757        (allocate-block linear-area reg-len)    ;advance free pointer
758        (setq l-b-p-array
759              (car (init-q-array l-b-p-area nil nil 'sym:art-special-pdl
760                        (list (setq spec-len (- (* sym:page-size
761                                                   (get-area-size 'sym:linear-bind-pdl-area))
762                                                (+ (length sym:special-pdl-leader-qs) 4))))
763                        nil (length sym:special-pdl-leader-qs))))
764        (allocate-block l-b-p-area spec-len)    ;advance free pointer
765        (stack-group-linkup sg pdl-array l-b-p-array)
766        (store-q-array-leader sg sym:sg-state (vfix initial-state))
767        (store-q-array-leader sg sym:sg-name (make-q-list 'sym:init-list-area name))
768        (store-q-array-leader sg sym:sg-regular-pdl-limit
769                              (make-q-list 'sym:init-list-area (- reg-len 100)))
770        (store-q-array-leader sg sym:sg-special-pdl-limit
771                              (make-q-list 'sym:init-list-area (- spec-len 100)))
772        (return (vmake-pointer sym:dtp-stack-group sg))))
773
774(defun stack-group-linkup (sg pdl-arrayp l-b-p-arrayp)
775  (store-q-array-leader l-b-p-arrayp sym:special-pdl-sg-head-pointer
776                        (vmake-pointer sym:dtp-stack-group sg))
777  (store-q-array-leader pdl-arrayp sym:reg-pdl-sg-head-pointer
778                        (vmake-pointer sym:dtp-stack-group sg))
779  (store-q-array-leader sg sym:sg-special-pdl
780                        (vmake-pointer sym:dtp-array-pointer l-b-p-arrayp))
781  (store-q-array-leader sg sym:sg-regular-pdl
782                        (vmake-pointer sym:dtp-array-pointer pdl-arrayp))
783  (store-q-array-leader sg sym:sg-initial-function-index (vfix 3)))
784
785;This better agree with the order of the list of qs in QCOM
786(defun init-system-communication-area (&aux (nqs 24.) adr)
787  (setq adr (allocate-block 'sym:system-communication-area nqs))
788  (vwrite (+ adr sym:%sys-com-area-origin-pntr)
789          (vmake-pointer sym:dtp-locative (get-area-origin 'sym:region-origin)))
790  (vwrite (+ adr sym:%sys-com-valid-size) (vfix 0))     ;fixed later
791  (vwrite (+ adr sym:%sys-com-page-table-pntr)
792          (vmake-pointer sym:dtp-locative (get-area-origin 'sym:page-table-area)))
793  (vwrite (+ adr sym:%sys-com-page-table-size)
794          (vfix (* (get-area-size 'sym:page-table-area) sym:page-size)))
795  (vwrite (+ adr sym:%sys-com-obarray-pntr) (qintern 'sym:obarray))
796  (vwrite (+ adr sym:%sys-com-remote-keyboard) (vfix 0))
797  (vwrite (+ adr sym:%sys-com-micro-load-m-data) (vfix 0))
798  (vwrite (+ adr sym:%sys-com-micro-load-a-data) (vfix 0))
799  (vwrite (+ adr sym:%sys-com-micro-load-address) (vfix 0))
800  (vwrite (+ adr sym:%sys-com-micro-load-flag) (vfix 0))
801  (vwrite (+ adr sym:%sys-com-unibus-interrupt-list) (vfix 0))
802  (vwrite (+ adr sym:%sys-com-temporary) (vfix 0))
803  (vwrite (+ adr sym:%sys-com-free-area/#-list) 0)      ;fixed later
804  (vwrite (+ adr sym:%sys-com-free-region/#-list) 0)    ;fixed later
805  (vwrite (+ adr sym:%sys-com-memory-size) (vfix 100000))       ;assume 32K, fixed later
806  (vwrite (+ adr sym:%sys-com-wired-size)  ;region-free-pointer is the first pageable area
807          (vfix (get-area-origin 'sym:region-free-pointer)))
808  (vwrite (+ adr sym:%sys-com-chaos-free-list) qnil)
809  (vwrite (+ adr sym:%sys-com-chaos-transmit-list) qnil)
810  (vwrite (+ adr sym:%sys-com-chaos-receive-list) qnil)
811  (vwrite (+ adr sym:%sys-com-debugger-requests) (vfix 0))
812  (vwrite (+ adr sym:%sys-com-debugger-keep-alive) (vfix 0))
813  (vwrite (+ adr sym:%sys-com-debugger-data-1) (vfix 0))
814  (vwrite (+ adr sym:%sys-com-debugger-data-2) (vfix 0))
815  (vwrite (+ adr sym:%sys-com-major-version) qnil)      ;I.e. fresh cold-load
816  (or (= nqs (length sym:system-communication-area-qs))
817      (ferror nil "QCOM and COLDUT disagree about system-communication-area")))
818
819(defun q-storage-finalize ()
820  (mapc (function store-support-vector) sym:support-vector-contents)
821  (store-nxtnil-cdr-code 'sym:support-entry-vector)
822  (mapc (function store-displaced-array-pointer) sym:area-list)
823  (scratch-store-q 'sym:active-micro-code-entries (vfix (length micro-code-entry-vector)))
824  ;; Transfer over free pointers
825  (do ((area-number 0 (1+ area-number))
826       (area-list sym:area-list (cdr area-list))
827       (rfp (get-area-origin 'sym:region-free-pointer))
828       (rgp (get-area-origin 'sym:region-gc-pointer))
829       (f))
830      ((null area-list))
831    (setq f (vfix (- (aref area-alloc-pointers area-number) (aref area-origins area-number))))
832    (vwrite (+ rfp area-number) f)
833    (vwrite (+ rgp area-number) f))
834
835  ;; Allocate rest of address space to the free area
836  (let ((fa (get-area-number 'sym:free-area))
837        (high-loc (aref area-alloc-bounds (1- (length sym:area-list)))))
838    (vwrite (+ (get-area-origin 'sym:system-communication-area) sym:%sys-com-valid-size)
839            (vfix high-loc))
840    (multiple-value-bind (ignore n-pages) (sys:find-disk-partition "PAGE")
841      (vwrite (+ (get-area-origin 'sym:region-origin) fa) (vfix high-loc))
842      (vwrite (+ (get-area-origin 'sym:region-length) fa)
843              (vfix (- (* n-pages sym:page-size) high-loc)))
844      (vwrite (+ (get-area-origin 'sym:region-bits) fa) (vfix 0))))
845  ;; Set up the area# and region# free lists
846  (vwrite (+ (get-area-origin 'sym:system-communication-area) sym:%sys-com-free-area/#-list)
847          (vfix (length sym:area-list)))
848  (vwrite (+ (get-area-origin 'sym:system-communication-area) sym:%sys-com-free-region/#-list)
849          (vfix (length sym:area-list)))
850  (do i (length sym:area-list) (1+ i) (= i sym:size-of-area-arrays)     ;all but the last
851    (vwrite (+ (get-area-origin 'sym:region-list-thread) i) (vfix (1+ i)))
852    (vwrite (+ (get-area-origin 'sym:area-region-list) i) (vfix (1+ i))))
853  (vwrite (+ (get-area-origin 'sym:region-list-thread) sym:size-of-area-arrays) (vfix 0))
854  (vwrite (+ (get-area-origin 'sym:area-region-list) sym:size-of-area-arrays) (vfix 0))
855  ;; Make certain areas look full
856  (dolist (area 'sym:(region-origin region-length region-free-pointer region-gc-pointer
857                      region-bits region-list-thread area-name area-region-list
858                      area-region-size area-maximum-size
859                      linear-pdl-area linear-bind-pdl-area))
860    (vwrite (+ (get-area-origin 'sym:region-free-pointer) (get-area-number area))
861            (vfix (* (get-area-size area) sym:page-size))))
862  ;; Initialize unused portions of the disk
863  (initialize-unused-pages)
864  (init-region-sorted-by-origin)
865  ;; Set up the page hash table to be empty except for the wired areas
866  ;; which will look like they are at virtual=real addresses.
867  ;; Cold-booting into this band will then do the right thing with it
868  (init-area-contents 'sym:page-table-area (vfix 0))
869  (dolist (area sym:area-list)                  ;For each wired area
870    (and (eq area 'sym:region-free-pointer) (return))   ;first non-wired area
871    (let* ((area-number (get-area-number area))
872           (area-base (aref area-origins area-number))
873           (area-bound (aref area-alloc-bounds area-number)))
874      (do ((pn (// area-base sym:page-size) (1+ pn))    ;For each page in that area
875           (n (// area-bound sym:page-size)))
876          (( pn n))
877        (cold-create-page area area-number pn pn))))
878  ;; Terminate areas which have overlying lists
879  (store-nxtnil-cdr-code 'sym:constants-area)
880  (store-nxtnil-cdr-code 'sym:scratch-pad-init-area)
881  (store-nxtnil-cdr-code 'sym:area-name)
882  (store-nxtnil-cdr-code 'sym:micro-code-entry-area)
883  (store-nxtnil-cdr-code 'sym:micro-code-entry-name-area)
884  (store-nxtnil-cdr-code 'sym:micro-code-entry-args-info-area)
885  (store-nxtnil-cdr-code 'sym:micro-code-entry-arglist-area)
886  (store-nxtnil-cdr-code 'sym:micro-code-exit-area))
887
888(defun initialize-unused-pages (&aux area address high)
889  (dolist (area-name (memq 'sym:extra-pdl-area sym:area-list))  ;no trash low fixed areas
890    (setq area (get-area-number area-name)
891          address (aref area-alloc-pointers area)
892          high (aref area-alloc-bounds area))
893    ;Page in all the fresh pages without really paging them in, thus initializing them
894    (do ((vpn (// (+ address sym:page-size -1) sym:page-size) (1+ vpn))
895         (hpn (// (+ high sym:page-size -1) sym:page-size)))
896        (( vpn hpn))
897      (vmem-find-page (* vpn sym:page-size) nil))))
898
899;Set up REGION-SORTED-BY-ORIGIN area.  Special notes:
900;    Zero-length regions have to come before other regions at the same address
901;    [alternatively they could not appear at all]
902(defun init-region-sorted-by-origin ()
903  (do ((mum (make-sorted-region-list)
904            (or (cdr mum) mum)) ;replicate last entry
905       (i 0 (1+ i))
906       (rso (get-area-origin 'sym:region-sorted-by-origin)))
907      ((> i sym:size-of-area-arrays))
908    (vwrite (+ rso i) (vfix (cdar mum)))))
909
910(defun make-sorted-region-list ()
911  (sort (do ((i 0 (1+ i))
912             (al sym:area-list (cdr al))
913             (l nil))
914            ((null al)
915             (nreverse l))
916          (or (eq (car al) 'sym:free-area)
917              (push (cons (aref area-origins i) i) l)))
918        (function (lambda (x y)
919           (cond ((= (car x) (car y))           ;if one is zero length, it -must- go first
920                  (cond ((= (aref area-origins (cdr x)) (aref area-alloc-bounds (cdr x))) t)
921                        ((= (aref area-origins (cdr y)) (aref area-alloc-bounds (cdr y))) nil)
922                        ((ferror nil "2 non-zero-length areas at same address"))))
923                 ((< (car x) (car y))))))))
924
925;Set up paging data structures
926(defun cold-create-page (area area-number virpage phypage)
927  (do ((pht-mask (- sym:size-of-page-table 2))
928       (access-and-status-code
929          (cond ((memq area sym:pdl-buffer-area-list) 5)
930                ((memq area sym:read-only-area-list) 12)
931                (t 14)))
932       (meta-bits (cond ((memq area sym:list-structured-areas) 60)
933                        ((eq area 'sym:extra-pdl-area) 44)
934                        (t 64))) ;symbolic?????
935       (swap-status-code
936          (cond ;((memq area sym:pdl-buffer-area-list) sym:%pht-swap-status-pdl-buffer)
937                ((memq area sym:wired-area-list) sym:%pht-swap-status-wired)
938                (t sym:%pht-swap-status-normal)))
939       (hash (logxor (ash virpage 2) (ash virpage -6)) (+ hash 2))
940       (pht (get-area-origin 'sym:page-table-area))
941       (ppd (get-area-origin 'sym:physical-page-data)))
942      (nil)
943    (cond ((= 0 (ldb sym:%%pht1-valid-bit
944                     (vread (+ pht (setq hash (logand hash pht-mask))))))
945           (vwrite (+ pht hash)
946                   (vfix (dpb virpage sym:%%pht1-virtual-page-number
947                              (dpb swap-status-code sym:%%pht1-swap-status-code
948                                   (dpb 1 sym:%%pht1-valid-bit 0)))))
949           (vwrite (+ pht hash 1)
950                   (vfix (dpb access-and-status-code sym:%%pht2-access-and-status-bits
951                              (dpb meta-bits sym:%%pht2-meta-bits
952                                   (dpb phypage sym:%%pht2-physical-page-number 0)))))
953           (vwrite (+ ppd phypage)
954                   (dpb area-number 2020 hash))
955           (return t)))))
956
957;;; Driver
958
959(defvar qfasl-file-list '(      "AI:LMFONT;CPTFON QFASL"
960                                "AI:LISPM;QRAND QFASL"
961                                "AI:LMIO;QIO QFASL"
962                                ;"AI:LMIO;RDTBL QFASL" ;done specially
963                                "AI:LMIO;READ QFASL"
964                                "AI:LMIO;PRINT QFASL"
965                                "AI:LMWIN;COLD QFASL"
966                                "AI:LISPM;SGFCTN QFASL"
967                                "AI:LISPM;QEV QFASL"
968                                "AI:LISPM;LTOP QFASL"
969                                "AI:LISPM;QFASL QFASL"
970                                "AI:LMIO;MINI QFASL"
971                                "AI:LISPM;LFL QFASL"  ))
972
973(defvar cold-list-area 'sym:init-list-area)     ;Where FROID (COLDLD) puts lists (usually)
974(defvar evals-to-be-sent-over)
975
976;User calls this to build a cold-load onto a band
977(defun make-cold (part-name)
978  (cond ((y-or-n-p (format nil "May I smash the /"~A/" partition, which contains /"~A/"?"
979                               part-name (si:partition-comment part-name 0)))
980         (si:update-partition-comment part-name "cold" 0)
981         (or (boundp 'big-fixnum) (load-parameters))
982         ;; Flush old state
983         (mapatoms #'(lambda (x) (remprop x 'q-atom-head)) sym-package nil)
984         (setq evals-to-be-sent-over nil)
985         (unwind-protect (progn (vmem-initialize part-name)
986                                (make-cold-1)
987                                (format nil "Boot off the ~A partition to test it."
988                                            part-name))
989           (vmem-finish)))))
990
991(defun make-cold-1 ()
992  ;; Divide up virtual memory into areas and initialize tables
993  (assign-values sym:area-list 0)
994  (create-areas)
995  (make-t-and-nil)
996  ;; Initialize various fixed areas and really random data tables
997  (init-area-contents 'sym:area-name qnil)
998  (store-list-of-atoms 'sym:area-name sym:area-list)
999  (storein-q-value-cell 'sym:area-list  ;Is this going to win?
1000                        (vmake-pointer sym:dtp-list (get-area-origin 'sym:area-name)))
1001  (mapc (function store-constant) sym:constants-page)   ;set up constants page
1002  (storein-q-value-cell 'sym:constants-page
1003                        (vmake-pointer sym:dtp-list (get-area-origin 'sym:constants-area)))
1004  (init-scratch-pad-area)
1005  (init-system-communication-area)
1006  (fix-certain-variables)
1007  (mapc (function store-lisp-value-list) sym:q-corresponding-variable-lists)
1008  (init-random-variables)
1009  (store-a-mem-location-names)
1010  (setq micro-code-entry-vector nil)
1011  (store-misc-u-entry-links)
1012  ;;Load up all those QFASL files
1013  (mapc 'cold-fasload qfasl-file-list)
1014  ;;Don't let list-structure portion of the readtable end up in a read-only area
1015  (let ((cold-list-area 'sym:property-list-area))  ;Random list-structured area
1016    (cold-fasload "AI:LMIO;RDTBL QFASL"))
1017  ;;THIS KLUDGE FIXES UP MACROS, SINCE THE FUNCTION MACRO IS NOT DEFINED YET
1018  ;;(BY SPECIAL DISPENSATION WE HAVE DEFPROP, PUTPROP, AND SPECIAL AROUND)
1019  ;;FURTHERMORE, SETQ ISN'T DEFINED YET, LOAD-TIME-SETQ FASL-OP SHOULD HAVE BEEN USED
1020  (do l evals-to-be-sent-over (cdr l) (null l)
1021    (cond ((memq (caar l) 'sym:(setq and or cond))
1022           (ferror nil "~A will get undefined function during initialization" (car l)))
1023          ((eq (caar l) 'sym:macro)
1024           (rplaca l (sublis (list (cons 'fcn (cadar l))
1025                                   (cons 'name (caddar l))
1026                                   (cons 'body (cdddar l)))
1027                             '(sym:fset (sym:quote fcn)
1028                                        (sym:quote (sym:macro
1029                                                     . (sym:lambda name . body)))))))))
1030 (setq evals-to-be-sent-over (nreverse evals-to-be-sent-over)) ;do in order specified
1031 (storein-q-value-cell 'sym:lisp-crash-list
1032                       ;; This MAKE-Q-LIST must not use the FASL-TEMP-AREA,
1033                       ;; because the list structure being created includes
1034                       ;; definitions of important macros.  The area used
1035                       ;; must not be an immediate write area.
1036                       (make-q-list 'sym:init-list-area evals-to-be-sent-over))
1037 ;;Everything compiled, etc. close off and write it out
1038 (format t "~&q-storage-finalize...")
1039 (q-storage-finalize))
1040
1041;nil and t must be stored manually since qnil and qtruth would not be bound when needed
1042(defun make-t-and-nil ()
1043  (setq qnil (vmake-pointer sym:dtp-symbol
1044                      (allocate-block 'sym:resident-symbol-area sym:length-of-atom-head)))
1045  (vwrite-cdr qnil sym:cdr-next (vmake-pointer sym:dtp-symbol-header
1046                                               (store-string 'sym:p-n-string "NIL")))
1047  (vwrite-cdr (+ qnil 1) sym:cdr-next qnil)
1048  (vwrite-cdr (+ qnil 2) sym:cdr-next (vmake-pointer sym:dtp-null qnil))
1049  (vwrite-cdr (+ qnil 3) sym:cdr-next qnil)
1050  (vwrite-cdr (+ qnil 4) sym:cdr-next qnil)
1051  (putprop 'sym:nil qnil 'q-atom-head)
1052  (setq qtruth (vmake-pointer sym:dtp-symbol
1053                   (allocate-block 'sym:resident-symbol-area sym:length-of-atom-head)))
1054  (vwrite-cdr qtruth sym:cdr-next (vmake-pointer sym:dtp-symbol-header
1055                                                 (store-string 'sym:p-n-string "T")))
1056  (vwrite-cdr (+ qtruth 1) sym:cdr-next qtruth)
1057  (vwrite-cdr (+ qtruth 2) sym:cdr-next (vmake-pointer sym:dtp-null qtruth))
1058  (vwrite-cdr (+ qtruth 3) sym:cdr-next qnil)
1059  (vwrite-cdr (+ qtruth 4) sym:cdr-next qnil)
1060  (putprop 'sym:t qtruth 'q-atom-head))
1061
1062;Fix the values of certain variables before they are sent over
1063(defun fix-certain-variables ()
1064  (dolist (sym '(sym:a-memory-virtual-address sym:unibus-virtual-address
1065                 sym:io-space-virtual-address))
1066    (set sym (lsh (ash (symeval sym) -3) 3)))   ;Change from bignum to fixnum
1067  (setq sym:prin1 nil)
1068  (setq sym:base (setq sym:ibase 8))
1069  (setq sym:*nopoint nil)
1070  (setq sym:for-cadr t))        ;Is this still used?
1071
1072;Initializations of all sorts of random variables.  Must follow the map
1073;over q-corresponding-variable-lists, because previous initializations are stored over.
1074(defun init-random-variables ()
1075  ;;set up array-types symbol (both value and function cells).
1076  ;;  the function cell is an array which gives maps numeric array type to symbolic name.
1077  ;;  the value cell is a list pointer into the above array, so is an ordered list
1078  ;;   of the array types.
1079  (init-q-array 'sym:control-tables 'sym:array-types 2 'sym:art-q-list '(32.) nil nil)
1080  (store-list-of-atoms 'sym:control-tables sym:array-types)
1081  (store-nils 'sym:control-tables (- 32. (length sym:array-types)))
1082  (storein-q-value-cell 'sym:array-types
1083    (vmake-pointer sym:dtp-list (- (aref area-alloc-pointers
1084                                         (get-area-number 'sym:control-tables))
1085                                   32.)))
1086  ;;set up the array-elements-per-q array.
1087  (init-q-array 'sym:control-tables 'sym:array-elements-per-q 2 ;fcn
1088                'sym:art-q-list '(32.) nil nil)
1089  (store-list-of-atoms 'sym:control-tables (make-ordered-array-list sym:array-elements-per-q))
1090  (store-nils 'sym:control-tables (- 32. (length sym:array-types)))
1091  ;;value cell of array-elements-per-q has assq list, is not same as array.
1092  ;;set up the array-bits-per-element array, similar
1093  (init-q-array 'sym:control-tables 'sym:array-bits-per-element 2 ;fcn
1094                'sym:art-q-list '(32.) nil nil)
1095  (store-list-of-atoms 'sym:control-tables
1096                       (make-ordered-array-list sym:array-bits-per-element))
1097  (store-nils 'sym:control-tables (- 32. (length sym:array-types)))
1098  ;;set up q-data-types
1099  (init-q-array 'sym:control-tables 'sym:q-data-types 2 'sym:art-q-list '(32.) nil
1100                (list (make-q-list 'sym:init-list-area (length sym:q-data-types))))
1101  (store-list-of-atoms 'sym:control-tables sym:q-data-types)
1102  (store-nils 'sym:control-tables (- 32. (length sym:q-data-types)))
1103  (storein-q-value-cell 'sym:q-data-types
1104    (vmake-pointer sym:dtp-list (- (aref area-alloc-pointers
1105                                         (get-area-number 'sym:control-tables))
1106                                   32.))))
Note: See TracBrowser for help on using the browser.