source: trunk/source/xdump/xfasload.lisp @ 14623

Last change on this file since 14623 was 14623, checked in by rme, 9 years ago

Remove yet more left-over debugging cruft.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 80.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17(in-package "CCL")
18
19
20(eval-when (:compile-toplevel :execute)
21(require "FASLENV" "ccl:xdump;faslenv")
22
23
24
25(defmacro defxloadfaslop (n arglist &body body)
26  `(setf (svref *xload-fasl-dispatch-table* ,n)
27         (nfunction ,n (lambda ,arglist ,@body))))
28
29(defmacro xload-copy-faslop (n)
30  `(let* ((n ,n))
31     (setf (svref *xload-fasl-dispatch-table* n)
32           (svref *fasl-dispatch-table* n))))
33)
34
35
36;;; I'm not sure that there's a better way to do this.
37
38(defparameter *xload-show-cold-load-functions* nil "Set to T when debugging")
39(defparameter *xload-special-binding-indices* nil)
40(defparameter *xload-reserved-special-binding-index-symbols*
41  '(*interrupt-level*))
42
43(defparameter *xload-next-special-binding-index* (length *xload-reserved-special-binding-index-symbols*))
44
45(defparameter *xload-target-nil* nil)
46(defparameter *xload-target-fixnumshift* nil)
47(defparameter *xload-target-fulltag-cons* nil)
48(defparameter *xload-target-fulltag-misc* nil)
49(defparameter *xload-target-misc-data-offset* nil)
50(defparameter *xload-target-fulltagmask* nil)
51(defparameter *xload-target-fulltag-cons* nil)
52(defparameter *xload-target-cons-size* nil)
53(defparameter *xload-target-car-offset* nil)
54(defparameter *xload-target-cdr-offset* nil)
55(defparameter *xload-target-misc-header-offset* nil)
56(defparameter *xload-target-misc-subtag-offset* nil)
57(defparameter *xload-target-unbound-marker* nil)
58(defparameter *xload-target-subtag-char* nil)
59(defparameter *xload-target-charcode-shift* nil)
60(defparameter *xload-target-big-endian* t)
61(defparameter *xload-host-big-endian* t)
62(defparameter *xload-target-use-code-vectors* t
63  "When true, assume that the target represents functions as a node vector with an immediate vector (a CODE-VECTOR) in its 0th element.  When false, assume that the target mixes code and constants in a single object.")
64(defparameter *xload-target-fulltag-for-symbols* nil)
65(defparameter *xload-target-fulltag-for-functions* nil)
66(defparameter *xload-target-char-code-limit* nil)
67
68
69(defvar *xload-backends* nil)
70(defvar *xload-default-backend*)
71(defvar *xload-target-backend*)
72
73(defparameter *xload-image-base-address* nil)
74
75(defparameter *xload-purespace-reserve* nil)
76(defparameter *xload-static-space-address* (ash 1 12))
77(defparameter *xload-static-space-size* (ash 8 10))
78(defparameter *xload-readonly-space-address* nil)
79(defparameter *xload-readonly-space-size* (ash 1 18))
80(defparameter *xload-dynamic-space-address* nil)
81(defparameter *xload-dynamic-space-size* (ash 1 18))
82(defparameter *xload-managed-static-space-address* nil)
83(defparameter *xload-managed-static-space-size* 0)
84(defparameter *xload-static-cons-space-address* nil)
85(defparameter *xload-static-cons-space-size* 0)
86
87(defstruct backend-xload-info
88  name
89  macro-apply-code-function
90  closure-trampoline-code
91  udf-code
92  default-image-name
93  default-startup-file-name
94  subdirs
95  compiler-target-name
96  image-base-address
97  nil-relative-symbols
98  static-space-init-function
99  purespace-reserve
100  static-space-address
101)
102
103(defun setup-xload-target-parameters ()
104  (let* ((arch (backend-target-arch *target-backend*)))
105    (setq *xload-image-base-address*
106          (backend-xload-info-image-base-address
107           *xload-target-backend*))
108    (setq *xload-purespace-reserve*
109          (backend-xload-info-purespace-reserve
110           *xload-target-backend*))
111    (setq *xload-readonly-space-address* *xload-image-base-address*)
112    (setq *xload-dynamic-space-address*
113          (+ *xload-image-base-address*
114             *xload-purespace-reserve*))
115    (setq *xload-managed-static-space-address* *xload-dynamic-space-address*
116          *xload-static-cons-space-address* *xload-dynamic-space-address*)
117    (setq *xload-static-space-address*
118          (backend-xload-info-static-space-address
119           *xload-target-backend*))
120    (setq *xload-target-nil*
121          (arch::target-nil-value arch))
122    (setq *xload-target-unbound-marker*
123          (arch::target-unbound-marker-value arch))
124    (setq *xload-target-misc-header-offset*
125          (- (arch::target-misc-data-offset arch)
126             (arch::target-lisp-node-size arch)))
127    (setq *xload-target-misc-subtag-offset*
128          (arch::target-misc-subtag-offset arch))
129    (setq *xload-target-fixnumshift*
130          (arch::target-word-shift arch))
131    (setq *xload-target-fulltag-cons*
132          (arch::target-cons-tag arch))
133    (setq *xload-target-car-offset*
134          (arch::target-car-offset arch))
135    (setq *xload-target-cdr-offset*
136          (arch::target-cdr-offset arch))
137    (setq *xload-target-cons-size*
138          (* 2 (arch::target-lisp-node-size arch)))
139    (setq *xload-target-fulltagmask*
140          (arch::target-fulltagmask arch))
141    (setq *xload-target-misc-data-offset*
142          (arch::target-misc-data-offset arch))
143    (setq *xload-target-fulltag-misc*
144          (arch::target-fulltag-misc arch))
145    (setq *xload-target-subtag-char*
146          (arch::target-subtag-char arch))
147    (setq *xload-target-charcode-shift*
148          (arch::target-charcode-shift arch))
149    (setq *xload-target-big-endian*
150          (arch::target-big-endian arch))
151    (setq *xload-host-big-endian*
152          (arch::target-big-endian
153           (backend-target-arch *host-backend*)))
154    (setq *xload-target-use-code-vectors*
155          (not (null (assoc :code-vector (arch::target-uvector-subtags arch)))))
156    (setq *xload-target-fulltag-for-symbols*
157          (if (arch::target-symbol-tag-is-subtag arch)
158            (arch::target-fulltag-misc arch)
159            (arch::target-symbol-tag arch)))
160    (setq *xload-target-fulltag-for-functions*
161          (if (arch::target-function-tag-is-subtag arch)
162            (arch::target-fulltag-misc arch)
163            (arch::target-function-tag arch)))
164    (setq *xload-target-char-code-limit*
165          (arch::target-char-code-limit arch))))
166
167
168
169(defun xload-target-consp (addr)
170  (and (= *xload-target-fulltag-cons* (logand addr *xload-target-fulltagmask*))
171       (not (= addr *xload-target-nil*))))
172
173
174(defun xload-target-listp (addr)
175  (or (= addr *xload-target-nil*)
176      (xload-target-consp addr)))
177
178
179(defun find-xload-backend (target)
180  (find target *xload-backends* :key #'backend-xload-info-name))
181
182(defun add-xload-backend (b)
183  (let* ((already (find-xload-backend (backend-xload-info-name b))))
184    (when already
185      (setq *xload-backends* (remove already *xload-backends*)))
186    (push b *xload-backends*)))
187
188
189(defun make-xload-header (element-count subtag)
190  (logior (ash element-count target::num-subtag-bits) subtag))
191
192
193(defparameter *xload-record-source-file-p* t)
194
195(defun xload-symbol-header ()
196  (make-xload-header target::symbol.element-count (xload-target-subtype :symbol)))
197
198(defparameter *xload-fasl-dispatch-table* (make-array (length *fasl-dispatch-table*)
199                                                     :initial-element #'%bad-fasl))
200
201(defun xload-swap-16 (16-bit-value)
202  (dpb (ldb (byte 8 0) 16-bit-value)
203       (byte 8 8)
204       (ldb (byte 8 8) 16-bit-value)))
205
206(defun xload-swap-32 (32-bit-value)
207  (dpb (xload-swap-16 (ldb (byte 16 0) 32-bit-value))
208       (byte 16 16)
209       (xload-swap-16 (ldb (byte 16 16) 32-bit-value))))
210
211(defun xload-swap-64 (64-bit-value)
212  (dpb (xload-swap-32 (ldb (byte 32 0) 64-bit-value))
213       (byte 32 32)
214       (xload-swap-32 (ldb (byte 32 32) 64-bit-value))))
215       
216(defun u32-ref (u32v byte-offset)
217  (declare (type (simple-array (unsigned-byte 32) (*)) u32v)
218           (fixnum byte-offset))
219  (locally (declare (optimize (speed 3) (safety 0)))
220    (let* ((val (aref u32v (ash byte-offset -2))))
221      (if (eq *xload-target-big-endian* *xload-host-big-endian*)
222        val
223        (xload-swap-32 val)))))
224
225(defun (setf u32-ref) (new u32v byte-offset)
226  (declare (type (simple-array (unsigned-byte 32) (*)) u32v)
227           (fixnum byte-offset))
228  (locally (declare (optimize (speed 3) (safety 0)))
229    (setf (aref u32v (ash byte-offset -2))
230          (if (eq *xload-target-big-endian* *xload-host-big-endian*)
231            (logand new #xffffffff)
232            (xload-swap-32 new)))))
233
234(defun u16-ref (u16v byte-offset)
235  (declare (type (simple-array (unsigned-byte 16) (*)) u16v)
236           (fixnum byte-offset))
237  (locally (declare (optimize (speed 3) (safety 0)))
238    (let* ((val (aref u16v (ash byte-offset -1))))
239      (if (eq *xload-target-big-endian* *xload-host-big-endian*)
240        val
241        (xload-swap-16 val)))))
242
243(defun (setf u16-ref) (new u16v byte-offset)
244  (declare (type (simple-array (unsigned-byte 16) (*)) u16v)
245           (fixnum byte-offset))
246  (locally (declare (optimize (speed 3) (safety 0)))
247    (setf (aref u16v (ash byte-offset -1))
248          (if (eq *xload-target-big-endian* *xload-host-big-endian*)
249            new
250            (xload-swap-16 new)))
251    new))
252
253(defun u8-ref (u8v byte-offset)
254  (declare (type (simple-array (unsigned-byte 8) (*)) u8v)
255           (fixnum byte-offset))
256  (locally (declare (optimize (speed 3) (safety 0)))
257    (aref u8v byte-offset)))
258
259(defun (setf u8-ref) (new u8v byte-offset)
260  (declare (type (simple-array (unsigned-byte 8) (*)) u8v)
261           (fixnum byte-offset))
262  (locally (declare (optimize (speed 3) (safety 0)))
263    (setf (aref u8v byte-offset) new)))
264
265(defun natural-ref (u32v byte-offset)
266  (target-word-size-case
267   (32 (u32-ref u32v byte-offset))
268   (64 (let* ((first (u32-ref u32v byte-offset))
269              (second (u32-ref u32v (+ byte-offset 4))))
270         (if *xload-target-big-endian*
271           (dpb first (byte 32 32) second)
272           (dpb second (byte 32 32) first))))))
273
274(defun (setf natural-ref) (new u32v byte-offset)
275  (target-word-size-case
276   (32 (setf (u32-ref u32v byte-offset) new))
277   (64 (let* ((high (ldb (byte 32 32) new))
278              (low (ldb (byte 32 0) new)))
279         (if *xload-target-big-endian*
280           (setf (u32-ref u32v byte-offset) high
281                 (u32-ref u32v (+ byte-offset 4)) low)
282           (setf (u32-ref u32v byte-offset) low
283                 (u32-ref u32v (+ byte-offset 4)) high))
284         new))))
285
286
287(defun xload-aligned-uvector-size (nbytes)
288  (target-word-size-case
289   (32 (logand (lognot 7) (+ 4 7 nbytes )))
290   (64 (logand (lognot 15) (+ 15 8 nbytes)))))
291
292(defparameter *xload-spaces* nil)
293(defparameter *xload-image-file* nil)
294(defvar *xload-image-file-name*)
295(defvar *xload-startup-file*)
296
297
298(defstruct xload-space
299  (vaddr 0)
300  (size (ash 1 18))
301  (lowptr 0)
302  (data nil)
303  (code 0))
304
305(defmethod print-object ((s xload-space) stream)
306  (print-unreadable-object (s stream :type t)
307    (format stream "~a @#x~8,'0x len = ~d" (xload-space-code s) (xload-space-vaddr s) (xload-space-lowptr s))))
308
309;;; :constructor ... :constructor ... <gasp> ... must remember ... :constructor
310
311(defun init-xload-space (vaddr size code)
312  (let* ((nfullwords (ash (+ size 3) -2))
313         (space (make-xload-space :vaddr vaddr
314                                 :size size
315                                 :data (make-array nfullwords
316                                                   :element-type '(unsigned-byte 32)
317                                                   :initial-element 0)
318                                 :code code)))
319    (push space *xload-spaces*)
320    space))
321
322;;; Nilreg-relative symbols.
323
324(defparameter %builtin-functions%
325  #(+-2 --2 *-2 /-2 =-2 /=-2 >-2 >=-2 <-2 <=-2 eql length sequence-type
326        assq memq logbitp logior-2 logand-2 ash 
327        %negate logxor-2 %aref1 %aset1
328        ;; add more
329        )
330  "Symbols naming fixed-arg, single-valued functions")
331       
332(defun xload-nrs ()
333  (mapcar
334   #'(lambda (s)
335       (or (assq s '((nil) (%pascal-functions%) (*all-metered-functions*)
336                      (*post-gc-hook*) (%handlers%) 
337                     (%finalization-alist%) (%closure-code%)))
338           s))
339   (backend-xload-info-nil-relative-symbols *xload-target-backend*)))
340
341
342
343(defun  %xload-unbound-function% ()
344  (+ *xload-dynamic-space-address* *xload-target-fulltag-misc*))
345
346(defparameter *xload-dynamic-space* nil)
347(defparameter *xload-readonly-space* nil)
348(defparameter *xload-static-space* nil)
349(defparameter *xload-managed-static-space* nil)
350(defparameter *xload-static-cons-space* nil)
351(defparameter *xload-symbols* nil)
352(defparameter *xload-symbol-addresses* nil)
353(defparameter *xload-package-alist* nil)         ; maps real package to clone
354(defparameter *xload-aliased-package-addresses* nil)     ; cloned package to address
355(defparameter *xload-cold-load-functions* nil)
356(defparameter *xload-cold-load-documentation* nil)
357(defparameter *xload-loading-file-source-file* nil)
358(defparameter *xload-loading-toplevel-location* nil)
359(defparameter *xload-early-class-cells* nil)
360(defparameter *xload-early-istruct-cells* nil)
361
362(defparameter *xload-pure-code-p* t)     ; when T, subprims are copied to readonly space
363                                        ; and code vectors are allocated there, reference subprims
364                                        ; pc-relative.
365
366
367       
368(defun xload-lookup-symbol (sym)
369  (gethash (%symbol->symptr sym) *xload-symbols*))
370
371(defun xload-lookup-symbol-address (addr)
372  (gethash addr *xload-symbol-addresses*))
373
374(defun (setf xload-lookup-symbol) (addr sym)
375  (setf (gethash (%symbol->symptr sym) *xload-symbols*) addr))
376
377(defun (setf xload-lookup-symbol-address) (sym addr)
378  (setf (gethash addr *xload-symbol-addresses*) sym))
379
380(defun xload-lookup-address (address)
381  (dolist (space *xload-spaces* (error "Address #x~8,'0x not found in defined address spaces ." address))
382    (let* ((vaddr (xload-space-vaddr space)))
383      (if (and (<= vaddr address)
384               (< address (+ vaddr (the fixnum (xload-space-size space)))))
385        (return (values (xload-space-data space) (- address vaddr)))))))
386
387(defun xload-u32-at-address (address)
388  (multiple-value-bind (v o) (xload-lookup-address address)
389    (u32-ref v o)))
390
391(defun (setf xload-u32-at-address) (new address)
392  (multiple-value-bind (v o) (xload-lookup-address address)
393    (setf (u32-ref v o) new)))
394
395(defun xload-natural-at-address (address)
396  (multiple-value-bind (v o) (xload-lookup-address address)
397    (natural-ref v o)))
398
399(defun (setf xload-natural-at-address) (new address)
400  (multiple-value-bind (v o) (xload-lookup-address address)
401    (setf (natural-ref v o) new)))
402   
403(defun xload-u16-at-address (address)
404  (multiple-value-bind (v o) (xload-lookup-address address)
405    (u16-ref v o)))
406
407(defun (setf xload-u16-at-address) (new address)
408  (multiple-value-bind (v o) (xload-lookup-address address)
409    (setf (u16-ref v o) new)))
410
411(defun xload-u8-at-address (address)
412  (multiple-value-bind (v o) (xload-lookup-address address)
413    (u8-ref v o)))
414
415(defun (setf xload-u8-at-address) (new address)
416  (multiple-value-bind (v o) (xload-lookup-address address)
417    (setf (u8-ref v o) new)))
418
419(defun xload-integer (imm &optional (nwords 1))
420  (let* ((arch (backend-target-arch *target-backend*))
421         (most-negative (arch::target-most-negative-fixnum arch))
422         (most-positive (arch::target-most-positive-fixnum arch)))
423  (if (and (typep imm 'integer)
424           (<= most-negative imm most-positive))
425    (ash imm (arch::target-fixnum-shift arch))
426    (let* ((bignum (xload-make-ivector
427                    *xload-dynamic-space*
428                    :bignum
429                    nwords)))
430      (dotimes (i nwords bignum)
431        (setf (xload-%fullword-ref bignum i) (ldb (byte 32 0) imm)
432              imm (ash imm -32)))))))
433
434;;; "grow" the space: make a new data vector. Copy old data
435;;;  to new data vector.  Update size and data fields.
436;;; Grow (arbitrarily) by 64K bytes, or as specified by caller.
437(defun xload-more-space (space &optional (delta (ash 1 16)))
438  (declare (fixnum delta))
439  (setq delta (logand (lognot 3) (the fixnum (+ delta 3))))
440  (let* ((old-size (xload-space-size space))
441         (old-data (xload-space-data space))
442         (old-nfullwords (ash old-size -2))
443         (delta-nfullwords (ash delta -2))
444         (new-size (+ old-size delta))
445         (new-nfullwords (+ old-nfullwords delta-nfullwords))
446         (new-data (make-array (the fixnum new-nfullwords)
447                               :element-type '(unsigned-byte 32)
448                               :initial-element 0)))
449    (declare (fixnum old-size old-nfullwords delta-nfullwords))
450    (declare (type (simple-array (unsigned-byte 32) (*)) old-data new-data))
451    (dotimes (i old-nfullwords)
452      (declare (optimize (speed 3) (safety 0)))
453      (setf (aref new-data i) (aref old-data i)))
454    (setf (xload-space-size space) new-size
455          (xload-space-data space) new-data)
456    new-size))
457                               
458
459(defun xload-alloc (space tag nbytes)
460  (declare (fixnum tag nbytes))
461  (when (logtest 7 nbytes) (error "~d not a multiple of 8 ." nbytes))
462  (let* ((free (xload-space-lowptr space)))
463    (if (> nbytes (the fixnum (- (the fixnum (xload-space-size space)) free)))
464      (xload-more-space space (the fixnum (+ nbytes (ash 1 16)))))
465    (setf (xload-space-lowptr space) (the fixnum (+ free nbytes)))
466    (let* ((offset (+ free tag)))
467      (declare (fixnum offset))
468      (values 
469       (the fixnum (+ (xload-space-vaddr space) offset))
470       (xload-space-data space)
471       offset))))
472
473;;; element-count doesn't include header
474(defun xload-alloc-fullwords (space tag nelements)
475  (xload-alloc space tag (xload-aligned-uvector-size (ash nelements 2))))
476
477(defun xload-alloc-halfwords (space tag nelements)
478  (xload-alloc space tag (xload-aligned-uvector-size (ash nelements 1))))
479
480(defun xload-alloc-bytes (space tag nelements)
481  (xload-alloc space tag (xload-aligned-uvector-size nelements)))
482
483(defun xload-alloc-doublewords (space tag nelements)
484  (xload-alloc space tag (xload-aligned-uvector-size (ash nelements 3))))
485
486
487
488
489(defun xload-make-cons (car cdr &optional (space *xload-dynamic-space*))
490  (multiple-value-bind (cell-addr data offset) (xload-alloc space  *xload-target-fulltag-cons* *xload-target-cons-size*)
491    (setf (natural-ref data (the fixnum (+ offset *xload-target-car-offset*))) car)
492    (setf (natural-ref data (the fixnum (+ offset *xload-target-cdr-offset*))) cdr)
493    cell-addr))
494
495;;; This initializes the gvector's contents to 0.  Might want to
496;;; consider initializing it to NIL for the benefit of package and
497;;; hashtable code.
498(defun xload-make-gvector (subtag len)
499  (unless (typep subtag 'fixnum)
500    (setq subtag (type-keyword-code subtag)))
501  (locally
502      (declare (fixnum subtag len))
503      (multiple-value-bind (cell-addr data offset)
504          (target-word-size-case
505           (32 (xload-alloc-fullwords *xload-dynamic-space* *xload-target-fulltag-misc* len))
506           (64 (xload-alloc-doublewords *xload-dynamic-space* *xload-target-fulltag-misc* len)))
507        (declare (fixnum offset))
508        (setf (natural-ref data (+ offset *xload-target-misc-header-offset*)) (make-xload-header len subtag))
509        cell-addr)))
510
511(defun xload-make-word-ivector (subtag len space)
512  (declare (fixnum subtag len))
513    (multiple-value-bind (cell-addr data offset) (xload-alloc-fullwords space  *xload-target-fulltag-misc* len)
514      (declare (fixnum offset))
515      (setf (natural-ref data (+ offset *xload-target-misc-header-offset*)) (make-xload-header len subtag))
516      cell-addr))
517
518(defun xload-package->addr (p)
519  (or (cdr (assq (or (cdr (assq p *xload-package-alist*)) 
520                     (error "Package ~s not cloned ." p))
521                 *xload-aliased-package-addresses*))
522      (error "Cloned package ~s: no assigned address . " p)))
523
524(defun xload-addr->package (a)
525  (or (car (rassoc (or (car (rassoc a *xload-aliased-package-addresses* :test #'eq))
526                       (error "Address ~d: no cloned package ." a))
527                   *xload-package-alist*))
528      (error "Package at address ~d not cloned ." a)))
529
530(defun xload-make-symbol (pname-address &optional
531                                        (package-address *xload-target-nil*)
532                                        (space *xload-dynamic-space*))
533  (let* ((sym
534          (target-word-size-case
535           (32 (xload-alloc-fullwords space *xload-target-fulltag-for-symbols* target::symbol.element-count))
536           (64 (xload-alloc-doublewords space *xload-target-fulltag-for-symbols* target::symbol.element-count))))
537         (sv (logior *xload-target-fulltag-misc*
538                     (logandc2 sym *xload-target-fulltagmask*))))
539    (setf (xload-%svref sv -1)  (xload-symbol-header))
540    (setf (xload-%svref sv target::symbol.flags-cell) 0)
541    ;; On PPC64, NIL's pname must be NIL.
542    (setf (xload-%svref sv target::symbol.pname-cell)
543          (if (and (target-arch-case (:ppc64 t) (otherwise nil))
544                   (= sym *xload-target-nil*))
545            *xload-target-nil*
546            pname-address))
547    (setf (xload-%svref sv target::symbol.vcell-cell) *xload-target-unbound-marker*)
548    (setf (xload-%svref sv target::symbol.package-predicate-cell) package-address)
549    (setf (xload-%svref sv target::symbol.fcell-cell) (%xload-unbound-function%))
550    (setf (xload-%svref sv target::symbol.plist-cell) *xload-target-nil*)
551    ;;(break "Made symbol at #x~x (#x~x)" cell-addr offset)
552    sym))
553
554;;; No importing or shadowing can (easily) happen during the cold
555;;; load; a symbol is present in no package other than its home
556;;; package.
557;;; This -just- finds or adds the symbol in the "clone" package's itab/etab.
558;;; Somebody else has to copy the symbol to the image ...
559(defun xload-intern (symbol)
560  (let* ((pname (symbol-name symbol))
561         (namelen (length pname))
562         (package (symbol-package symbol))
563         (clone (cdr (assq package *xload-package-alist*))))
564    (unless (nth-value 1 (%find-package-symbol pname clone namelen))    ; already there
565      (without-interrupts
566       (let* ((htab (if (%get-htab-symbol pname namelen (pkg.etab package)) 
567                      (pkg.etab clone) 
568                      (pkg.itab clone))))
569         (%htab-add-symbol symbol htab (nth-value 2 (%get-htab-symbol pname namelen htab))))))
570    t))
571     
572
573(defun xload-dnode-align (nbytes)
574  (target-word-size-case
575   (32 (logand (lognot 7) (+ nbytes 7 4)))
576   (64 (logand (lognot 15) (+ nbytes 15 8)))))
577
578(defun xload-subtag-bytes (subtag element-count)
579  (funcall (arch::target-array-data-size-function
580            (backend-target-arch *target-backend*))
581           subtag element-count))
582
583   
584(defun xload-make-dfloat (space high low)
585  (let* ((double-float-tag (arch::target-double-float-tag
586                            (backend-target-arch *target-backend*))))
587    (target-word-size-case
588     (32
589      (multiple-value-bind (dfloat-addr v o) (xload-alloc-fullwords space *xload-target-fulltag-misc* 3)
590        (declare (fixnum o))
591        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-header-offset*))) 
592              (make-xload-header 3 double-float-tag))
593        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset* 4)))
594              (if *xload-target-big-endian* high low))
595        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset* 8)))
596              (if *xload-target-big-endian* low high))
597        dfloat-addr))
598     (64
599      (multiple-value-bind (dfloat-addr v o) (xload-alloc-fullwords space *xload-target-fulltag-misc* 2)
600        (declare (fixnum o))
601        (setf (natural-ref v (the fixnum (+ o *xload-target-misc-header-offset*))) 
602              (make-xload-header 2 double-float-tag))
603        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset*)))
604              (if *xload-target-big-endian* high low))
605        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset* 4)))
606              (if *xload-target-big-endian* low high))
607        dfloat-addr)))))
608
609(defun xload-make-sfloat (space bits)
610  (let* ((single-float-tag (arch::target-single-float-tag
611                            (backend-target-arch *target-backend*))))
612    (target-word-size-case
613     (32
614      (multiple-value-bind (sfloat-addr v o) (xload-alloc-fullwords space *xload-target-fulltag-misc* 1)
615        (declare (fixnum o))
616        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-header-offset*))) 
617              (make-xload-header 1 single-float-tag))
618        (setf (u32-ref v (the fixnum (+ o *xload-target-misc-data-offset*))) bits)
619        sfloat-addr))
620     (64
621      (logior (ash bits 32) single-float-tag)))))
622       
623(defun xload-make-ivector (space subtag nelements)
624  (unless (typep subtag 'fixnum)
625    (setq subtag (type-keyword-code subtag)))
626  (locally
627      (declare (fixnum subtag nelements))
628    (multiple-value-bind (addr v o) (xload-alloc space *xload-target-fulltag-misc* (xload-dnode-align (xload-subtag-bytes subtag nelements)))
629      (declare (fixnum o))
630      (setf (natural-ref v (the fixnum (- o *xload-target-fulltag-misc*))) (make-xload-header nelements subtag))
631      (values addr v o))))
632
633(defun xload-%svref (addr i)
634  (declare (fixnum i))
635  (if (= (the fixnum (logand addr *xload-target-fulltagmask*)) *xload-target-fulltag-misc*)
636    (target-word-size-case
637     (32
638      (multiple-value-bind (v offset) (xload-lookup-address addr)
639        (declare (fixnum offset))
640        (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2)))))))))
641     (64
642      (multiple-value-bind (v offset) (xload-lookup-address addr)
643        (declare (fixnum offset))
644        (natural-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 3))))))))))
645    (error "Not a vector: #x~x" addr)))   
646
647(defun (setf xload-%svref) (new addr i)
648  (declare (fixnum i))
649  (if (= (the fixnum (logand addr *xload-target-fulltagmask*)) *xload-target-fulltag-misc*)
650    (target-word-size-case
651     (32
652      (multiple-value-bind (v offset) (xload-lookup-address addr)
653        (declare (fixnum offset))
654        (setf (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2))))))) new)))
655     (64
656      (multiple-value-bind (v offset) (xload-lookup-address addr)
657        (declare (fixnum offset))
658        (setf (natural-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 3))))))) new))))
659    (error "Not a vector: #x~x" addr)))
660
661
662(defun xload-%fullword-ref (addr i)
663  (declare (fixnum i))
664  (if (= (the fixnum (logand addr *xload-target-fulltagmask*))
665           *xload-target-fulltag-misc*)
666      (multiple-value-bind (v offset) (xload-lookup-address addr)
667        (declare (fixnum offset))
668        (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2))))))))
669      (error "Not a vector: #x~x" addr)))
670
671(defun (setf xload-%fullword-ref) (new addr i)
672  (declare (fixnum i))
673  (if (= (the fixnum (logand addr *xload-target-fulltagmask*))
674         *xload-target-fulltag-misc*)
675    (multiple-value-bind (v offset) (xload-lookup-address addr)
676      (declare (fixnum offset))
677      (setf (u32-ref v (the fixnum (+ offset (the fixnum (+ *xload-target-misc-data-offset* (the fixnum (ash i 2))))))) new))
678    (error "Not a vector: #x~x" addr)))
679
680(defun xload-car (addr)
681  (if (xload-target-listp addr)
682    (multiple-value-bind (v offset) (xload-lookup-address addr)
683      (declare (fixnum offset))
684      (natural-ref v (the fixnum (+ offset *xload-target-car-offset*))))
685    (error "Not a list: #x~x" addr)))
686
687(defun (setf xload-car) (new addr)
688  (if (xload-target-consp addr)
689    (multiple-value-bind (v offset) (xload-lookup-address addr)
690      (declare (fixnum offset))
691      (setf (natural-ref v (the fixnum (+ offset *xload-target-car-offset*))) new))
692    (error "Not a cons: #x~x" addr)))
693
694(defun xload-cdr (addr)
695  (if (xload-target-listp addr)
696    (multiple-value-bind (v offset) (xload-lookup-address addr)
697      (declare (fixnum offset))
698      (natural-ref v (the fixnum (+ offset *xload-target-cdr-offset*))))
699    (error "Not a list: #x~x" addr)))
700
701(defun (setf xload-cdr) (new addr)
702  (if (xload-target-consp addr)
703    (multiple-value-bind (v offset) (xload-lookup-address addr)
704      (declare (fixnum offset))
705      (setf (natural-ref v (the fixnum (+ offset *xload-target-cdr-offset*))) new))
706    (error "Not a cons: #x~x" addr)))
707
708(defun xload-caar (addr)
709  (xload-car (xload-car addr)))
710
711(defun xload-cadr (addr)
712  (xload-car (xload-cdr addr)))
713
714(defun xload-cdar (addr)
715  (xload-cdr (xload-car addr)))
716
717(defun xload-cddr (addr)
718  (xload-cdr (xload-cdr addr)))
719
720(defun xload-symbol-value (addr)
721  (unless (= *xload-target-fulltag-for-symbols*
722             (logand addr *xload-target-fulltagmask*))
723    (error "~& Not a symbol address: #x~x" addr))
724  (setq addr (logior *xload-target-fulltag-misc*
725                     (logandc2 addr *xload-target-fulltagmask*)))
726  (if (= (xload-%svref addr -1) (xload-symbol-header))
727    (xload-%svref addr target::symbol.vcell-cell)
728    (error "Not a symbol: #x~x" addr)))
729 
730
731(defun (setf xload-symbol-value) (new addr)
732  (unless (= *xload-target-fulltag-for-symbols*
733             (logand addr *xload-target-fulltagmask*))
734    (error "~& Not a symbol address: #x~x" addr))
735  (setq addr (logior *xload-target-fulltag-misc*
736                     (logandc2 addr *xload-target-fulltagmask*)))
737  (if (= (xload-%svref addr -1) (xload-symbol-header))
738    (setf (xload-%svref addr target::symbol.vcell-cell) new)
739    (error "Not a symbol: #x~x" addr)))
740
741(defun xload-set (sym val)
742  (check-type sym symbol)
743  (check-type val integer)
744  (let* ((symaddr (xload-lookup-symbol sym)))
745    (unless symaddr (error "Symbol address not found: ~s ." sym))
746    (setf (xload-symbol-value symaddr) val)))
747
748(defun xload-fset (addr def)
749  (unless (= *xload-target-fulltag-for-symbols*
750             (logand addr *xload-target-fulltagmask*))
751    (error "~& Not a symbol address: #x~x" addr))
752  (setq addr (logior *xload-target-fulltag-misc*
753                     (logandc2 addr *xload-target-fulltagmask*)))
754  (if (= (xload-%svref addr -1) (xload-symbol-header))
755    (setf (xload-%svref addr target::symbol.fcell-cell) def)
756    (error "Not a symbol: #x~x" addr)))
757
758(defun (setf xload-symbol-plist) (new addr)
759  (unless (= *xload-target-fulltag-for-symbols*
760             (logand addr *xload-target-fulltagmask*))
761    (error "~& Not a symbol address: #x~x" addr))
762  (setq addr (logior *xload-target-fulltag-misc*
763                     (logandc2 addr *xload-target-fulltagmask*)))
764  (let* ((plist (xload-%svref addr target::symbol.plist-cell)))
765    (if (xload-target-consp plist)
766      (let* ((str (xload-get-string (xload-%svref addr target::symbol.pname-cell))))
767        (warn "Symbol at #x~x (~a): plist already set." addr str))
768      (setf (xload-%svref addr target::symbol.plist-cell)
769            (xload-make-cons *xload-target-nil* new)))
770    new))
771
772;;; Emulate REGISTER-ISTRUCT-CELL, kinda.  Maintain
773;;; *xload-early-istruct-istruct-cells* in the image.
774(defun xload-register-istruct-cell (xsym)
775  (do* ((alist *xload-early-istruct-cells* (xload-cdr alist)))
776       ((= alist *xload-target-nil*)
777        (let* ((pair (xload-make-cons xsym *xload-target-nil*)))
778          (setq *xload-early-istruct-cells*
779                (xload-make-cons pair *xload-early-istruct-cells*))
780          pair))
781    (let* ((pair (xload-car alist)))
782      (when (= (xload-car pair) xsym)
783        (return pair)))))
784
785 
786;;; This handles constants set to themselves.  Unless
787;;; PRESERVE-CONSTANTNESS is true, the symbol's $sym_vbit_const bit is
788;;; cleared.  (This is done because the kernel tries to call EQUALP if
789;;; constants are "redefined", and EQUALP may not be defined early
790;;; enough.)
791(defun xload-copy-symbol (symbol &key
792                                 (preserve-constantness (keywordp symbol))
793                                 (space *xload-dynamic-space*))
794  (or (xload-lookup-symbol symbol)
795      (let* ((pname (symbol-name symbol))
796             (home-package (symbol-package symbol))
797             (addr (xload-make-symbol (xload-save-string pname (length pname))
798                                      (if home-package 
799                                        (xload-package->addr home-package)
800                                        *xload-target-nil*)
801                                      space))
802             (svaddr (logior *xload-target-fulltag-misc*
803                             (logandc2 addr *xload-target-fulltagmask*))))
804        (xload-intern symbol)
805        (let* ((bits (logandc2 (%symbol-bits symbol)
806                               (ash 1 $sym_vbit_typeppred))))
807          (setf (xload-%svref svaddr target::symbol.flags-cell)
808                (ash (if preserve-constantness
809                       bits
810                       (logand (lognot (ash 1 $sym_vbit_const)) bits))
811                     *xload-target-fixnumshift*)))
812        (if (and (constantp symbol)
813                 (eq (symbol-value symbol) symbol))
814          (setf (xload-symbol-value addr) addr))
815        (setf (xload-lookup-symbol-address addr) symbol)
816        (setf (xload-lookup-symbol symbol) addr))))
817
818
819;;; Write a list to dynamic space.  No detection of circularity or
820;;; structure sharing.  The cdr of the final cons can be nil (treated
821;;; as *xload-target-nil*.  All cars must be addresses.
822
823(defun xload-save-list (l)
824  (if (atom l)
825    (or l *xload-target-nil*)
826    (xload-make-cons (car l) (xload-save-list (cdr l)))))
827
828(defun xload-save-string (str &optional (n (length str)))
829  (declare (fixnum n))
830  (let* ((subtag (type-keyword-code :simple-string)))
831    (multiple-value-bind (addr v offset) (xload-make-ivector *xload-readonly-space* subtag n)
832      (case *xload-target-char-code-limit*
833        (256 (do* ((p (+ offset *xload-target-misc-data-offset*)
834                      (1+ p))
835                   (i 0 (1+ i)))
836                  ((= i n) str)
837               (declare (fixnum i p))
838               (setf (u8-ref v p) (char-code (schar str i)))))
839        (t
840         (do* ((p (+ offset *xload-target-misc-data-offset*)
841                      (+ p 4))
842                   (i 0 (1+ i)))
843                  ((= i n) str)
844               (declare (fixnum i p))
845               (setf (u32-ref v p) (char-code (schar str i))))))
846        addr)))
847
848;;; Read a string from fasl file, save it to readonly-space.
849(defun %xload-fasl-vreadstr (s)
850  (multiple-value-bind (str n new-p) (%fasl-vreadstr s)
851    (declare (fixnum n))
852    (values (xload-save-string str n) str n new-p)))
853
854;;; Read a string from fasl file, save it to readonly-space.
855;;; (assumes variable-length encoding.)
856(defun %xload-fasl-nvreadstr (s)
857  (multiple-value-bind (str n new-p) (%fasl-nvreadstr s)
858    (declare (fixnum n))
859    (values (xload-save-string str n) str n new-p)))
860
861(defun xload-clone-packages (packages)
862  (let* ((alist (mapcar #'(lambda (p)
863                            (cons p
864                                  (gvector :package
865                                            (cons (make-array (the fixnum (length (car (uvref p 0))))
866                                                              :initial-element 0)
867                                                  (cons 0 (cddr (pkg.itab p))))
868                                            (cons (make-array
869                                                   (the fixnum
870                                                     (length
871                                                      (car
872                                                       (pkg.etab p))))
873                                                   :initial-element 0)
874                                                  (cons 0 (cddr (pkg.etab p))))
875                                            nil                         ; used
876                                            nil                         ; used-by
877                                            (copy-list (pkg.names p))     ; names
878                                            nil ;shadowed
879                                            nil ;lock
880                                            nil ;intern-hook
881                                            )))
882                        packages)))
883    (flet ((lookup-clone (p) (let* ((clone (cdr (assq p alist))))
884                               (when clone (list clone)))))
885      (dolist (pair alist alist)
886        (let* ((orig (car pair))
887               (dup (cdr pair)))
888          (setf (pkg.used dup) (mapcan #'lookup-clone (pkg.used orig))
889                (pkg.used-by dup) (mapcan #'lookup-clone (pkg.used-by orig))))))))
890
891;;; Dump each cloned package into dynamic-space; return an alist
892(defun xload-assign-aliased-package-addresses (alist)
893  (let* ((addr-alist (mapcar #'(lambda (pair)
894                                 (let* ((p (cdr pair))
895                                        (v (xload-make-gvector :package (uvsize p))))
896                                   (setf (xload-%svref v pkg.names)
897                                         (xload-save-list (mapcar #'(lambda (n) (xload-save-string n))
898                                                                 (pkg.names p))))
899                                   (cons p v)))
900                             alist)))
901    (flet ((clone->addr (clone)
902             (or (cdr (assq clone addr-alist)) (error "cloned package ~S not found ." clone))))
903      (dolist (pair addr-alist addr-alist)
904        (let* ((p (car pair))
905               (v (cdr pair)))
906          (setf (xload-%svref v pkg.used)
907                (xload-save-list (mapcar #'clone->addr (pkg.used p)))
908                (xload-%svref v pkg.used-by)
909                (xload-save-list (mapcar #'clone->addr (pkg.used-by p)))
910                (xload-%svref v pkg.shadowed) 
911                (xload-save-list (mapcar #'xload-copy-symbol (pkg.shadowed p)))
912                (xload-%svref v pkg.intern-hook)
913                *xload-target-nil*
914                ))))))
915
916
917
918(defun xload-fasload (pathnames)
919  (dolist (path pathnames)
920    (multiple-value-bind (*load-pathname* *load-truename* source-file) (find-load-file (merge-pathnames path))
921      (unless *load-truename*
922        (return (signal-file-error $err-no-file path)))
923      (setq path *load-truename*)
924      (let* ((*readtable* *readtable*)
925             (*package* *ccl-package*)   ; maybe just *package*
926             (*loading-files* (cons path *loading-files*))
927             (*xload-loading-file-source-file* nil)
928             (*xload-loading-toplevel-location* nil)
929             (*loading-file-source-file* (namestring source-file)))
930        (when *load-verbose*
931          (format t "~&;Loading ~S..." *load-pathname*)
932          (force-output))
933        (multiple-value-bind (winp err) (%fasload (native-translated-namestring path) *xload-fasl-dispatch-table*)
934          (if (not winp) (%err-disp err)))))))
935 
936
937
938
939(defun xload-save-htab (htab)
940  (let* ((htvec (car htab))
941         (len (length htvec))
942         (xvec (xload-make-gvector :simple-vector len))
943         (deleted-marker *xload-target-unbound-marker*))
944    (dotimes (i len)
945      (let* ((s (%svref htvec i)))
946        (setf (xload-%svref xvec i)
947              (if s
948                (if (symbolp s)
949                  (or (xload-lookup-symbol s) deleted-marker)
950                  0)
951                (if (= (logand *xload-target-nil* *xload-target-fulltagmask*)
952                       *xload-target-fulltag-for-symbols*)
953                  *xload-target-nil*
954                  (+ *xload-target-nil*
955                     (let* ((arch (backend-target-arch *target-backend*)))
956                       (+ (arch::target-t-offset arch)
957                          (ash 8 (arch::target-word-shift arch))))))))))
958    (xload-make-cons 
959     xvec 
960     (xload-make-cons
961      (xload-integer (cadr htab))
962      (xload-integer (cddr htab))))))
963
964(defun xload-finalize-packages ()
965  (dolist (pair *xload-aliased-package-addresses*)
966    (let* ((p (car pair))
967           (q (cdr pair)))
968      (setf (xload-%svref q pkg.etab) (xload-save-htab (pkg.etab p)))
969      (setf (xload-%svref q pkg.itab) (xload-save-htab (pkg.itab p))))))
970
971(defun xload-get-string (address)
972  (multiple-value-bind (v o) (xload-lookup-address address)
973    (let* ((header (natural-ref v (+ o *xload-target-misc-header-offset*)))
974           (len (ash header (- target::num-subtag-bits)))
975           (str (make-string len))
976           (p (+ o *xload-target-misc-data-offset*)))
977      (case *xload-target-char-code-limit*
978        (256
979         (dotimes (i len str)
980           (setf (schar str i) (code-char (u8-ref v (+ p i))))))
981        (t
982         (dotimes (i len str)
983           (setf (schar str i) (code-char (u32-ref v (+ p (* i 4)))))))))))
984
985               
986(defun xload-save-code-vector (code)
987  (let* ((read-only-p *xload-pure-code-p*)
988         (vlen (uvsize code))
989         (prefix (arch::target-code-vector-prefix (backend-target-arch
990                                                   *target-backend*)))
991         (n (+ (length prefix) vlen)))
992    (declare (fixnum n))
993    (let* ((vector (xload-make-ivector 
994                    (if read-only-p
995                      *xload-readonly-space*
996                      *xload-dynamic-space*)
997                    :code-vector
998                    n))
999           (j -1))
1000      (declare (fixnum j))
1001      (dotimes (i n)
1002        (setf (xload-%fullword-ref vector i)
1003              (if prefix
1004                (pop prefix)
1005                (uvref code (incf j)))))
1006      vector)))
1007                         
1008;;; For debugging
1009(defun xload-show-list (l)
1010  (labels ((show-list (l)
1011             (unless (= l *xload-target-nil*)
1012               (format t "#x~x" (xload-car l))
1013               (setq l (xload-cdr l))
1014               (unless (= l *xload-target-nil*)
1015                 (format t " ")
1016                 (show-list l)))))
1017    (format t "~&(")
1018    (show-list l)
1019    (format t ")")))
1020
1021(defun xload-initial-packages ()
1022  (mapcar #'find-package '("CL" "CCL"  "KEYWORD" "TARGET" "OS")))
1023
1024
1025(defun xfasload (output-file &rest pathnames)
1026  (let* ((*xload-symbols* (make-hash-table :test #'eq))
1027         (*xload-symbol-addresses* (make-hash-table :test #'eql))
1028         (*xload-spaces* nil)
1029         (*xload-early-class-cells* nil)
1030         (*xload-early-istruct-cells* *xload-target-nil*)
1031         (*xload-readonly-space* (init-xload-space *xload-readonly-space-address* *xload-readonly-space-size* area-readonly))
1032         (*xload-dynamic-space* (init-xload-space *xload-dynamic-space-address* *xload-dynamic-space-size* area-dynamic))
1033         (*xload-static-space* (init-xload-space *xload-static-space-address* *xload-static-space-size* area-static))
1034         (*xload-managed-static-space* (init-xload-space *xload-managed-static-space-address* *xload-managed-static-space-size* area-managed-static))
1035         (*xload-static-cons-space* (init-xload-space *xload-static-cons-space-address* *xload-static-cons-space-size* area-static-cons))
1036                                                 
1037         (*xload-package-alist* (xload-clone-packages (xload-initial-packages)))
1038         (*xload-cold-load-functions* nil)
1039         (*xload-cold-load-documentation* nil)
1040         (*xload-loading-file-source-file* nil)
1041         (*xload-loading-toplevel-location* nil)
1042         (*xload-aliased-package-addresses* nil)
1043         (*xload-special-binding-indices*
1044          (make-hash-table :test #'eql))
1045         (*xload-next-special-binding-index*
1046          (length *xload-reserved-special-binding-index-symbols*)))
1047    (funcall (backend-xload-info-static-space-init-function
1048              *xload-target-backend*))
1049    ;; Create %unbound-function% and the package objects in dynamic space,
1050    ;; then fill in the nilreg-relative symbols in static space.
1051    ;; Then start consing ..
1052    (if *xload-target-use-code-vectors*
1053      ;; The undefined-function object is a 1-element simple-vector (not
1054      ;; a function vector).  The code-vector in its 0th element should
1055      ;; report the appropriate error.
1056      ;; On the ARM: make a two-element vector: entrypoint, code-vector.
1057      (let* ((udf-object (xload-make-gvector :simple-vector 1)))
1058        (target-arch-case
1059         (:arm
1060          (setf (xload-%svref udf-object 0)
1061                (+ (subprim-name->offset '.SPfix-nfn-entrypoint *target-backend*)
1062                   #x40)))
1063         (otherwise
1064          (setf (xload-%svref udf-object 0)
1065                (xload-save-code-vector
1066                 (backend-xload-info-udf-code
1067                  *xload-target-backend*))))))
1068      (let* ((udf-object (xload-make-gvector :simple-vector 1)))
1069        (setf (xload-%svref udf-object 0) (backend-xload-info-udf-code
1070                                           *xload-target-backend*))))
1071     
1072    (setq *xload-aliased-package-addresses* (xload-assign-aliased-package-addresses *xload-package-alist*))
1073    (dolist (pair (xload-nrs))
1074      (let* ((val-p (consp pair))
1075             (val (if val-p (or (cdr pair) *xload-target-nil*)))
1076             (sym (if val-p (car pair) pair)))
1077        (xload-copy-symbol sym
1078                           :preserve-constantness t
1079                           :space *xload-static-space*)
1080        (when val-p (xload-set sym val))))
1081                                        ; This could be a little less ... procedural.
1082    (xload-set '*package* (xload-package->addr *ccl-package*))
1083    (xload-set '*keyword-package* (xload-package->addr *keyword-package*))
1084    (xload-set '%all-packages% (xload-save-list (mapcar #'cdr *xload-aliased-package-addresses*)))
1085    (xload-set '%unbound-function% (%xload-unbound-function%))
1086    (xload-set '*gc-event-status-bits* (xload-integer 0 #|(ash 1 $gc-integrity-check-bit)|#))
1087
1088    (xload-set '%toplevel-catch% (xload-copy-symbol :toplevel))
1089    (if *xload-target-use-code-vectors*
1090      (xload-set '%closure-code% (xload-save-code-vector
1091                                  (backend-xload-info-closure-trampoline-code
1092                                   *xload-target-backend*)))
1093      (xload-set '%closure-code% *xload-target-nil*))
1094    (let* ((macro-apply-code (funcall
1095                              (backend-xload-info-macro-apply-code-function
1096                               *xload-target-backend*))))
1097
1098      (xload-set '%macro-code%
1099                 (if *xload-target-use-code-vectors*
1100                   (xload-save-code-vector macro-apply-code)
1101                   macro-apply-code)))
1102    (let* ((len (length %builtin-functions%))
1103           (v (xload-make-gvector :simple-vector len)))
1104      (dotimes (i len)
1105        (setf (xload-%svref v i) (xload-copy-symbol (svref %builtin-functions% i))))
1106      (xload-set '%builtin-functions% v))
1107    (xload-copy-symbol '*xload-startup-file*)
1108    (xload-fasload pathnames)
1109    (xload-set '*xload-startup-file*
1110               (xload-save-string *xload-startup-file*))
1111    (let* ((toplevel (xload-symbol-value (xload-lookup-symbol '%toplevel-function%))))     
1112      (when (or (= toplevel *xload-target-unbound-marker*)
1113                (= toplevel *xload-target-nil*))
1114        (warn "~S not set in loading ~S ." '%toplevel-function pathnames)))
1115    (setf (xload-symbol-value (xload-copy-symbol '*xload-cold-load-functions*))
1116          (xload-save-list (setq *xload-cold-load-functions*
1117                                 (nreverse *xload-cold-load-functions*))))
1118    (setf (xload-symbol-value (xload-copy-symbol '*early-class-cells*))
1119          (xload-save-list (mapcar #'xload-save-list *xload-early-class-cells*)))
1120    (setf (xload-symbol-value (xload-copy-symbol '*istruct-cells*))
1121          *xload-early-istruct-cells*)
1122    (let* ((svnrev (local-svn-revision))
1123           (tree (svn-tree)))
1124      (setf (xload-symbol-value (xload-copy-symbol '*openmcl-svn-revision*))
1125            (typecase svnrev
1126              (fixnum (ash svnrev *xload-target-fixnumshift*))
1127              (string (xload-save-string (if tree (format nil "~a-~a" svnrev tree) svnrev)))
1128              (t *xload-target-nil*))))
1129    (let* ((experimental-features *build-time-optional-features*))
1130      (setf (xload-symbol-value (xload-copy-symbol '*optional-features*))
1131            (xload-save-list (mapcar #'xload-copy-symbol experimental-features))))
1132                             
1133    (when *xload-show-cold-load-functions*
1134      (format t "~&cold-load-functions list:")
1135      (xload-show-list (xload-symbol-value (xload-copy-symbol '*xload-cold-load-functions*))))
1136    (setf (xload-symbol-value (xload-copy-symbol '*xload-cold-load-documentation*))
1137          (xload-save-list (setq *xload-cold-load-documentation*
1138                                 (nreverse *xload-cold-load-documentation*))))
1139    (dolist (s *xload-reserved-special-binding-index-symbols*)
1140      (xload-ensure-binding-index (xload-copy-symbol s)))
1141    (xload-finalize-packages)
1142    #+debug
1143    (maphash #'(lambda (addr idx)
1144                 (format t "~&~d: ~s" idx
1145                         (xload-lookup-symbol-address addr)))
1146             *xload-special-binding-indices*)
1147    (xload-dump-image output-file *xload-image-base-address*)))
1148
1149(defun xload-dump-image (output-file heap-start)
1150  (declare (ftype (function (t t list)) write-image-file))
1151  (write-image-file output-file
1152                    heap-start
1153                    (list *xload-static-space*
1154                          *xload-readonly-space*
1155                          *xload-dynamic-space*
1156                          *xload-managed-static-space*
1157                          *xload-static-cons-space*)))
1158                   
1159
1160
1161
1162
1163
1164;;; The xloader
1165
1166(xload-copy-faslop $fasl-noop)
1167(xload-copy-faslop $fasl-vetab-alloc)
1168(xload-copy-faslop $fasl-veref)
1169
1170;;; Should error if epush bit set, else push on
1171;;; *xload-cold-load-functions* or something.
1172(defxloadfaslop $fasl-lfuncall (s)
1173  (let* ((fun (%fasl-expr-preserve-epush s)))
1174    (when (faslstate.faslepush s)
1175      (error "Can't call function for value : ~s" fun))
1176    (when *xload-show-cold-load-functions*
1177      (format t "~& cold-load function: #x~x" fun))
1178    (push fun *xload-cold-load-functions*)))
1179
1180(xload-copy-faslop $fasl-globals)        ; what the hell did this ever do ?
1181
1182;;; fasl-char: maybe epush, return target representation of BASE-CHARACTER
1183(defxloadfaslop $fasl-char (s)
1184  (let* ((code (%fasl-read-count s))
1185         (target-char (logior *xload-target-subtag-char*
1186                              (ash code *xload-target-charcode-shift*))))
1187    (%epushval s target-char)))
1188
1189
1190
1191(defxloadfaslop $fasl-dfloat (s)
1192  (%epushval s (xload-make-dfloat *xload-readonly-space* (%fasl-read-long s) (%fasl-read-long s))))
1193
1194(defxloadfaslop $fasl-sfloat (s)
1195  (%epushval s (xload-make-sfloat *xload-readonly-space* (%fasl-read-long s))))
1196
1197(defun xload-read-utf-8-string (s v o nchars nextra)
1198  (declare (fixnum nchars nextra))
1199  (if (eql 0 nextra)
1200    (dotimes (i nchars)
1201      (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
1202            (%fasl-read-byte s)) )
1203    (flet ((trailer-byte ()
1204             (when (> nextra 0)
1205               (decf nextra)
1206               (let* ((b (%fasl-read-byte s)))
1207                 (declare ((unsigned-byte 8) b))
1208                 (and (>= b #x80)
1209                      (< b #xc0)
1210                      (logand b #x3f))))))
1211      (declare (inline trailer-byte))
1212      (dotimes (i nchars)
1213        (let* ((b0 (%fasl-read-byte s)))
1214          (declare ((unsigned-byte 8) b0))
1215          (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
1216                (or
1217                 (cond ((< b0 #x80) b0)
1218                       ((and (>= b0 #xc2)
1219                             (< b0 #xe0))
1220                        (let* ((b1 (trailer-byte)))
1221                          (and b1 (logior (ash (logand b0 #x1f) 6) b1))))
1222                       ((and (>= b0 #xe0)
1223                             (< b0 #xf0))
1224                        (let* ((b1 (trailer-byte))
1225                               (b2 (trailer-byte)))
1226                          (and b1 b2 (logior (ash (logand b0 #x0f) 12)
1227                                             (logior (ash b1 6)
1228                                                     b2)))))
1229                       ((and (>= b0 #xf0)
1230                             (< b0 #xf5))
1231                        (let* ((b1 (trailer-byte))
1232                               (b2 (trailer-byte))
1233                               (b3 (trailer-byte)))
1234                          (and b1
1235                               b2
1236                               b3
1237                               (logior (ash (logand b0 #x7) 18)
1238                                       (logior (ash b1 12)
1239                                               (logior (ash b2 6)
1240                                                       b3)))))))
1241                 (char-code #\Replacement_Character))))))))
1242
1243
1244(defxloadfaslop $fasl-vstr (s)
1245  (let* ((nchars (%fasl-read-count s))
1246         (nextra (%fasl-read-count s)))
1247    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string nchars)
1248      (%epushval s str)
1249      (xload-read-utf-8-string s v o nchars nextra)
1250      str)))
1251
1252(defxloadfaslop $fasl-nvstr (s)
1253  (let* ((n (%fasl-read-count s)))
1254    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n)
1255      (%epushval s str)
1256      (case *xload-target-char-code-limit*
1257        (256
1258         (dotimes (i n)
1259           (setf (u8-ref v (+ o i *xload-target-misc-data-offset*))
1260                 (%fasl-read-byte s))))
1261        (t
1262         (dotimes (i n)
1263           (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
1264                 (%fasl-read-byte s)))))
1265      str)))
1266
1267;;; Allegedly deprecated.
1268(defxloadfaslop $fasl-fixnum (s)
1269  (%epushval s (xload-integer
1270                ;; This nonsense converts unsigned %fasl-read-long
1271                ;; result to signed
1272                (rlet ((long :long))
1273                  (setf (%get-long long) (%fasl-read-long s))
1274                  (%get-long long)))))
1275
1276(defxloadfaslop $fasl-word-fixnum (s)
1277  (%epushval s (xload-integer (%word-to-int (%fasl-read-word s)))))
1278
1279(defxloadfaslop $fasl-s32 (s)
1280  (%epushval s (xload-integer (%fasl-read-signed-long s))))
1281
1282(defxloadfaslop $fasl-s64 (s)
1283  (%epushval s (xload-integer (logior (ash (%fasl-read-signed-long s) 32)
1284                                      (%fasl-read-long s))
1285                              2)))
1286
1287(defun xload-set-binding-address (symbol-address idx)
1288  (unless (= *xload-target-fulltag-for-symbols*
1289             (logand symbol-address *xload-target-fulltagmask*))
1290    (error "~& Not a symbol address: #x~x" symbol-address))
1291  (setq symbol-address
1292        (logior *xload-target-fulltag-misc*
1293                (logandc2 symbol-address *xload-target-fulltagmask*)))
1294  (setf (xload-%svref symbol-address target::symbol.binding-index-cell)
1295        (ash idx *xload-target-fixnumshift*))
1296  (setf (gethash symbol-address *xload-special-binding-indices*) idx))
1297
1298(defun xload-ensure-binding-index (symbol-address)
1299  (or (gethash symbol-address *xload-special-binding-indices*)
1300      (let* ((sym (xload-lookup-symbol-address symbol-address))
1301             (pos (position sym *xload-reserved-special-binding-index-symbols*)))
1302        (xload-set-binding-address
1303         symbol-address
1304         (if pos
1305           (1+ pos)
1306           (incf *xload-next-special-binding-index*))))))
1307
1308(defun %xload-fasl-vmake-symbol (s &optional idx)
1309  (let* ((sym (xload-make-symbol (%xload-fasl-vreadstr s))))
1310    (when idx
1311      (xload-ensure-binding-index sym))
1312    (%epushval s sym)))
1313
1314(defun %xload-fasl-nvmake-symbol (s &optional idx)
1315  (let* ((sym (xload-make-symbol (%xload-fasl-nvreadstr s))))
1316    (when idx
1317      (xload-ensure-binding-index sym))
1318    (%epushval s sym)))
1319
1320
1321
1322(defxloadfaslop $fasl-vmksym (s)
1323  (%xload-fasl-vmake-symbol s))
1324
1325(defxloadfaslop $fasl-nvmksym (s)
1326  (%xload-fasl-nvmake-symbol s))
1327
1328(defxloadfaslop $fasl-vmksym-special (s)
1329  (%xload-fasl-vmake-symbol s t))
1330
1331(defxloadfaslop $fasl-nvmksym-special (s)
1332  (%xload-fasl-nvmake-symbol s t))
1333
1334(defun %xload-fasl-vintern (s package &optional idx)
1335  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
1336    (without-interrupts
1337     (multiple-value-bind (cursym access internal external) (%find-symbol str len package)
1338       (unless access
1339         (unless new-p (setq str (%fasl-copystr str len)))
1340         (setq cursym (%add-symbol str package internal external)))
1341       ;; cursym now exists in the load-time world; make sure that it exists
1342       ;; (and is properly "interned" in the world we're making as well)
1343       (let* ((symaddr (xload-copy-symbol cursym)))
1344         (when idx
1345           (xload-ensure-binding-index symaddr))
1346         (%epushval s symaddr))))))
1347
1348(defun %xload-fasl-nvintern (s package &optional idx)
1349  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
1350    (without-interrupts
1351     (multiple-value-bind (cursym access internal external) (%find-symbol str len package)
1352       (unless access
1353         (unless new-p (setq str (%fasl-copystr str len)))
1354         (setq cursym (%add-symbol str package internal external)))
1355       ;; cursym now exists in the load-time world; make sure that it exists
1356       ;; (and is properly "interned" in the world we're making as well)
1357       (let* ((symaddr (xload-copy-symbol cursym)))
1358         (when idx
1359           (xload-ensure-binding-index symaddr))
1360         (%epushval s symaddr))))))
1361
1362
1363(defxloadfaslop $fasl-vintern (s)
1364  (%xload-fasl-vintern s *package*))
1365
1366(defxloadfaslop $fasl-nvintern (s)
1367  (%xload-fasl-nvintern s *package*))
1368
1369(defxloadfaslop $fasl-vintern-special (s)
1370  (%xload-fasl-vintern s *package* t))
1371
1372(defxloadfaslop $fasl-nvintern-special (s)
1373  (%xload-fasl-nvintern s *package* t))
1374
1375(defxloadfaslop $fasl-vpkg-intern (s)
1376  (let* ((addr (%fasl-expr-preserve-epush  s))
1377         (pkg (xload-addr->package addr)))
1378    (%xload-fasl-vintern s pkg)))
1379
1380(defxloadfaslop $fasl-nvpkg-intern (s)
1381  (let* ((addr (%fasl-expr-preserve-epush  s))
1382         (pkg (xload-addr->package addr)))
1383    (%xload-fasl-nvintern s pkg)))
1384
1385(defxloadfaslop $fasl-vpkg-intern-special (s)
1386  (let* ((addr (%fasl-expr-preserve-epush  s))
1387         (pkg (xload-addr->package addr)))
1388    (%xload-fasl-vintern s pkg t)))
1389
1390(defxloadfaslop $fasl-nvpkg-intern-special (s)
1391  (let* ((addr (%fasl-expr-preserve-epush  s))
1392         (pkg (xload-addr->package addr)))
1393    (%xload-fasl-nvintern s pkg t)))
1394
1395(defun %xload-fasl-vpackage (s)
1396  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
1397    (let* ((p (%find-pkg str len)))
1398      (%epushval s (xload-package->addr 
1399                    (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))))
1400
1401(defun %xload-fasl-nvpackage (s)
1402  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
1403    (let* ((p (%find-pkg str len)))
1404      (%epushval s (xload-package->addr 
1405                    (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))))
1406
1407
1408(defxloadfaslop $fasl-vpkg (s)
1409  (%xload-fasl-vpackage s))
1410
1411(defxloadfaslop $fasl-nvpkg (s)
1412  (%xload-fasl-nvpackage s))
1413
1414(defxloadfaslop $fasl-cons (s)
1415  (let* ((cons (%epushval s (xload-make-cons *xload-target-nil* *xload-target-nil*))))
1416    (setf (xload-car cons) (%fasl-expr s)
1417          (xload-cdr cons) (%fasl-expr s))
1418    (setf (faslstate.faslval s) cons)))
1419   
1420
1421(defun %xload-fasl-vlistX (s dotp)
1422  (let* ((len (%fasl-read-count s)))
1423    (declare (fixnum len))
1424    (let* ((val (%epushval s (xload-make-cons *xload-target-nil* *xload-target-nil*)))
1425           (tail val))
1426      (setf (xload-car val) (%fasl-expr s))
1427      (dotimes (i len)
1428        (setf (xload-cdr tail) (setq tail (xload-make-cons  (%fasl-expr s) *xload-target-nil*))))
1429      (if dotp
1430        (setf (xload-cdr tail) (%fasl-expr s)))
1431      (setf (faslstate.faslval s) val))))
1432
1433(defxloadfaslop $fasl-vlist (s)
1434  (%xload-fasl-vlistX s nil))
1435
1436(defxloadfaslop $fasl-vlist* (s)
1437  (%xload-fasl-vlistX s t))
1438
1439(defxloadfaslop $fasl-nil (s)
1440  (%epushval s *xload-target-nil*))
1441
1442(defxloadfaslop $fasl-timm (s)
1443  (let* ((val (%fasl-read-long s)))
1444    #+paranoid (unless (= (logand $typemask val) $t_imm) 
1445                 (error "Bug: expected immediate-tagged object, got ~s ." val))
1446    (%epushval s val)))
1447
1448
1449(defxloadfaslop $fasl-platform (s)
1450  (%cant-epush s)
1451  (let* ((platform (%fasl-expr s))
1452         (backend-name (backend-xload-info-compiler-target-name
1453                                 *xload-target-backend*))
1454         (backend (find-backend backend-name)))
1455    (declare (fixnum platform))
1456    (unless (= platform (ash (backend-target-platform backend)
1457                             *xload-target-fixnumshift*))
1458      (error "Not a ~A fasl file : ~s" backend-name (faslstate.faslfname s)))))
1459
1460
1461(defxloadfaslop $fasl-symfn (s)
1462  (let* ((symaddr (%fasl-expr-preserve-epush s))
1463         (fnobj (xload-%svref symaddr target::symbol.fcell-cell)))
1464    (if (and (= *xload-target-fulltag-misc*
1465                (logand fnobj *xload-target-fulltagmask*))
1466             (= (type-keyword-code :function) (xload-u8-at-address (+ fnobj *xload-target-misc-subtag-offset*))))
1467      (%epushval s fnobj)
1468      (error "symbol at #x~x is unfbound . " symaddr))))
1469
1470(defxloadfaslop $fasl-eval (s)
1471  (let* ((expr (%fasl-expr-preserve-epush s)))
1472    (cond ((and (xload-target-consp expr)
1473                (eq (xload-lookup-symbol-address (xload-car expr))
1474                    'find-class-cell)
1475                (xload-target-consp (xload-car (xload-cdr expr)))
1476                (eq (xload-lookup-symbol-address (xload-car (xload-car (xload-cdr expr))))
1477                    'quote))
1478           (let* ((class-name (xload-cadr (xload-cadr expr)))
1479                  (cell (cdr (assoc class-name *xload-early-class-cells*))))
1480             (unless cell
1481               (setq cell (xload-make-gvector :istruct 5))
1482               (setf (xload-%svref cell 0) (xload-register-istruct-cell
1483                                            (xload-copy-symbol 'class-cell)))
1484               (setf (xload-%svref cell 1) class-name)
1485               (setf (xload-%svref cell 2) *xload-target-nil*)
1486               (setf (xload-%svref cell 3) (xload-copy-symbol '%make-instance))
1487               (setf (xload-%svref cell 4) *xload-target-nil*)
1488               (push (cons class-name cell) *xload-early-class-cells*))
1489             (%epushval s cell)))
1490          ((and (xload-target-consp expr)
1491                (eq (xload-lookup-symbol-address (xload-car expr))
1492                    'register-istruct-cell)
1493                (xload-target-consp (xload-cadr expr))
1494                (eq (xload-lookup-symbol-address (xload-cdar expr))
1495                    'quote))
1496           (%epushval s (xload-register-istruct-cell (xload-cadr (xload-cadr expr)))))
1497          (t
1498           (error "Can't evaluate expression ~s in cold load ." expr)
1499           (%epushval s (eval expr))))))         ; could maybe evaluate symbols, constants ...
1500
1501
1502(defun xload-target-subtype (name)
1503  (or
1504   (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
1505   (error "Unknown uvector type name ~s" name)))
1506
1507(defxloadfaslop $fasl-vivec (s)
1508  (let* ((subtag (%fasl-read-byte s))
1509         (element-count (%fasl-read-count s)))
1510    (declare (fixnum subtag))
1511    (multiple-value-bind (vector v o)
1512                         (xload-make-ivector 
1513                          *xload-readonly-space*
1514                          subtag 
1515                          element-count)
1516      (%epushval s vector)
1517      (%fasl-read-n-bytes s v (+ o  *xload-target-misc-data-offset*) (xload-subtag-bytes subtag element-count))
1518      vector)))
1519
1520(defun xfasl-read-ivector (s subtag)
1521  (let* ((element-count (%fasl-read-count s)))
1522    (multiple-value-bind (vector v o)
1523                         (xload-make-ivector 
1524                          *xload-readonly-space*
1525                          subtag 
1526                          element-count)
1527      (%epushval s vector)
1528      (%fasl-read-n-bytes s
1529                          v
1530                          (+ o *xload-target-misc-data-offset*)
1531                          (xload-subtag-bytes subtag element-count))
1532      vector)))
1533
1534(defxloadfaslop $fasl-u8-vector (s)
1535  (xfasl-read-ivector s (xload-target-subtype :unsigned-8-bit-vector)))
1536
1537(defxloadfaslop $fasl-s8-vector (s)
1538  (xfasl-read-ivector s (xload-target-subtype :signed-8-bit-vector)))
1539
1540(defxloadfaslop $fasl-u16-vector (s)
1541  (xfasl-read-ivector s (xload-target-subtype :unsigned-16-bit-vector)))
1542
1543(defxloadfaslop $fasl-s16-vector (s)
1544  (xfasl-read-ivector s (xload-target-subtype :signed-16-bit-vector)))
1545
1546(defxloadfaslop $fasl-u32-vector (s)
1547  (xfasl-read-ivector s (xload-target-subtype :unsigned-32-bit-vector)))
1548
1549(defxloadfaslop $fasl-s32-vector (s)
1550  (xfasl-read-ivector s (xload-target-subtype :signed-32-bit-vector)))
1551
1552
1553;;; We really can't compile 64-bit vectors on a 32-bit host.
1554#+64-bit-target
1555(defxloadfaslop $fasl-u64-vector (s)
1556  (xfasl-read-ivector s (xload-target-subtype :unsigned-64-bit-vector)))
1557
1558#+64-bit-target
1559(defxloadfaslop $fasl-u64-vector (s)
1560  (xfasl-read-ivector s (xload-target-subtype :unsigned-64-bit-vector)))
1561
1562(defxloadfaslop $fasl-bit-vector (s)
1563  (xfasl-read-ivector s (xload-target-subtype :bit-vector)))
1564
1565(defxloadfaslop $fasl-bignum32 (s)
1566  (xfasl-read-ivector s (xload-target-subtype :bignum)))
1567
1568(defxloadfaslop $fasl-single-float-vector (s)
1569  (xfasl-read-ivector s (xload-target-subtype :single-float-vector)))
1570
1571(defxloadfaslop $fasl-double-float-vector (s)
1572  (target-word-size-case
1573   (64 (xfasl-read-ivector s (xload-target-subtype :double-float-vector)))
1574   (32
1575    (let* ((element-count (%fasl-read-count s)))
1576      (multiple-value-bind (vector v o)
1577          (xload-make-ivector 
1578           *xload-readonly-space*
1579           (xload-target-subtype :double-float-vector)
1580           element-count)
1581        (%epushval s vector)
1582        (%fasl-read-n-bytes s v (+ o (arch::target-misc-dfloat-offset (backend-target-arch *target-backend*))) (xload-subtag-bytes (xload-target-subtype :double-float-vector)  element-count))
1583        vector)))))
1584
1585(defxloadfaslop $fasl-code-vector (s)
1586  (let* ((element-count (%fasl-read-count s))
1587         (subtag (xload-target-subtype :code-vector)))
1588    (multiple-value-bind (vector v o)
1589                         (xload-make-ivector 
1590                          (if (not *xload-pure-code-p*)
1591                            *xload-dynamic-space* 
1592                            *xload-readonly-space*)
1593                          subtag 
1594                          element-count)
1595      (%epushval s vector)
1596      (%fasl-read-n-bytes s v (+ o
1597                                 *xload-target-misc-data-offset*)
1598                          (xload-subtag-bytes subtag element-count))
1599      vector)))
1600
1601(defun xfasl-read-gvector (s subtype)
1602  (declare (fixnum subtype))
1603  (let* ((n (%fasl-read-count s))
1604         (vector (xload-make-gvector subtype n)))
1605    (%epushval s vector)
1606    (dotimes (i n (setf (faslstate.faslval s) vector))
1607      (setf (xload-%svref vector i) (%fasl-expr s)))))
1608 
1609(defxloadfaslop $fasl-vgvec (s)
1610  (let* ((subtype (%fasl-read-byte s)))
1611    (xfasl-read-gvector s subtype)))
1612
1613(defxloadfaslop $fasl-vector-header (s)
1614  (xfasl-read-gvector s (xload-target-subtype :vector-header)))
1615
1616(defxloadfaslop $fasl-array-header (s)
1617  (xfasl-read-gvector s (xload-target-subtype :array-header)))
1618
1619(defxloadfaslop $fasl-ratio (s)
1620  (let* ((r (xload-make-gvector (xload-target-subtype :ratio)
1621                                target::ratio.element-count)))
1622    (%epushval s r)
1623    (setf (xload-%svref r target::ratio.numer-cell) (%fasl-expr s)
1624          (xload-%svref r target::ratio.denom-cell) (%fasl-expr s))
1625    (setf (faslstate.faslval s) r)))
1626
1627(defxloadfaslop $fasl-complex (s)
1628  (let* ((c (xload-make-gvector (xload-target-subtype :complex)
1629                                target::complex.element-count)))
1630    (%epushval s c)
1631    (setf (xload-%svref c target::complex.realpart-cell) (%fasl-expr s)
1632          (xload-%svref c target::complex.imagpart-cell) (%fasl-expr s))
1633    (setf (faslstate.faslval s) c)))
1634
1635
1636
1637(defxloadfaslop $fasl-t-vector (s)
1638  (xfasl-read-gvector s (xload-target-subtype :simple-vector)))
1639
1640(defxloadfaslop $fasl-function (s)
1641  (xfasl-read-gvector s (xload-target-subtype :function)))
1642
1643(defxloadfaslop $fasl-istruct (s)
1644  (xfasl-read-gvector s (xload-target-subtype :istruct)))
1645
1646(defun xload-lfun-name (lf)
1647  (let* ((lfv (logior *xload-target-fulltag-misc*
1648                      (logandc2 lf *xload-target-fulltagmask*)))
1649         (header (xload-%svref lfv -1)))
1650    (unless (= (type-keyword-code :function)
1651               (logand header (1- (ash 1 target::num-subtag-bits))))
1652      (error "Not a function address: ~x" lf))
1653    (let* ((n (ash header (- target::num-subtag-bits))))
1654      (if (> n 2)
1655        (let* ((bits (ash (xload-%svref lfv (1- n))
1656                          (- *xload-target-fixnumshift*))))
1657          (unless (logbitp $lfbits-noname-bit bits)
1658            (xload-%svref lfv (- n 2))))
1659        (error "Teeny, tiny, little function : ~s" lf)))))
1660
1661
1662(defun xload-record-source-file (symaddr indicator)
1663  (when *xload-record-source-file-p*
1664    (when (or (eq indicator 'function)
1665              (eq indicator 'variable))
1666      (let* ((keyaddr (xload-copy-symbol 'bootstrapping-source-files))
1667             (pathaddr (or *xload-loading-toplevel-location*
1668                           *xload-loading-file-source-file*
1669                           (if *loading-file-source-file*
1670                             (setq *xload-loading-file-source-file* (xload-save-string *loading-file-source-file*))))))
1671        (when pathaddr
1672          (let* ((keyval (if (eq indicator 'function)
1673                           (xload-make-cons  pathaddr *xload-target-nil*)
1674                           (xload-make-cons
1675                            (xload-make-cons 
1676                             (xload-make-cons  (xload-copy-symbol indicator) pathaddr)
1677                             *xload-target-nil*)
1678                            *xload-target-nil*))))
1679            (setf (xload-symbol-plist symaddr) (xload-make-cons keyaddr keyval))))))))
1680
1681(defun xload-set-documentation (symaddr indicator doc)
1682  ;; Should maybe check further that it's a string
1683  ;; and it would hurt for whatever processes *xload-cold-load-documentation*
1684  ;; to do some checking there as well.
1685  (when (= (the fixnum (logand doc *xload-target-fulltagmask*))
1686           *xload-target-fulltag-misc*)
1687    (push (xload-save-list
1688           (list symaddr
1689                 (xload-copy-symbol indicator)
1690                 doc))
1691          *xload-cold-load-documentation*)))
1692
1693
1694
1695(defxloadfaslop $fasl-defun (s)
1696  (%cant-epush s)
1697  (let* ((fun (%fasl-expr s))
1698         (doc (%fasl-expr s)))
1699    (let* ((sym (xload-lfun-name fun)))
1700      (unless (= doc *xload-target-nil*)
1701        (xload-set-documentation sym 'function doc))
1702      (xload-record-source-file sym 'function)
1703      (xload-fset sym fun))))
1704
1705(defxloadfaslop $fasl-macro (s)
1706  (%cant-epush s)
1707  (let* ((fun (%fasl-expr s))
1708         (doc (%fasl-expr s)))
1709    (let* ((sym (xload-lfun-name fun))
1710           (vector (xload-make-gvector :simple-vector 2)))
1711      (setf (xload-%svref vector 0) (xload-symbol-value (xload-lookup-symbol '%macro-code%))
1712            (xload-%svref vector 1) fun)
1713      (unless (= doc *xload-target-nil*)
1714        (xload-set-documentation sym 'function doc))
1715      (xload-record-source-file sym 'function)
1716      (xload-fset sym vector))))
1717
1718(defxloadfaslop $fasl-defconstant (s)
1719  (%cant-epush s)
1720  (let* ((sym (%fasl-expr s))
1721         (val (%fasl-expr s))
1722         (doc (%fasl-expr s)))
1723    (unless (= doc *xload-target-nil*)
1724      (xload-set-documentation sym 'variable doc))
1725    (xload-record-source-file sym 'variable)
1726    (setf (xload-symbol-value sym) val)
1727    (let* ((sv (logior *xload-target-fulltag-misc*
1728                       (logandc2 sym *xload-target-fulltagmask*))))
1729      (setf (xload-%svref sv target::symbol.flags-cell)
1730            (ash 
1731             (logior (ash 1 $sym_vbit_special) 
1732                     (ash 1 $sym_vbit_const) 
1733                     (ash (xload-%svref sv target::symbol.flags-cell)
1734                        (- *xload-target-fixnumshift*)))
1735             *xload-target-fixnumshift*)))))
1736
1737(defxloadfaslop $fasl-defparameter (s)
1738  (%cant-epush s)
1739  (let* ((sym (%fasl-expr s))
1740         (val (%fasl-expr s))
1741         (doc (%fasl-expr s)))
1742    (unless (= doc *xload-target-nil*)
1743      (xload-set-documentation sym 'variable doc))
1744    (xload-record-source-file sym 'variable)
1745    (setf (xload-symbol-value sym) val)
1746    (let* ((sv (logior *xload-target-fulltag-misc*
1747                       (logandc2 sym *xload-target-fulltagmask*))))
1748      (setf (xload-%svref sv target::symbol.flags-cell)
1749            (ash 
1750             (logior (ash 1 $sym_vbit_special) 
1751                     (ash (xload-%svref sv target::symbol.flags-cell)
1752                          (- *xload-target-fixnumshift*)))
1753             *xload-target-fixnumshift*)))))
1754
1755(defxloadfaslop $fasl-defvar (s)
1756  (%cant-epush s)
1757  (let* ((sym (%fasl-expr s)))
1758    (xload-record-source-file sym 'variable)
1759    (let* ((sv (logior *xload-target-fulltag-misc*
1760                       (logandc2 sym *xload-target-fulltagmask*))))
1761      (setf (xload-%svref sv target::symbol.flags-cell)
1762            (ash 
1763             (logior (ash 1 $sym_vbit_special) 
1764                     (ash (xload-%svref sv target::symbol.flags-cell)
1765                          (- *xload-target-fixnumshift*)))
1766             *xload-target-fixnumshift*)))))
1767
1768(defxloadfaslop $fasl-defvar-init (s)
1769  (%cant-epush s)
1770  (let* ((sym (%fasl-expr s))
1771         (val (%fasl-expr s))
1772         (doc (%fasl-expr s)))
1773    (unless (= doc *xload-target-nil*)
1774      (xload-set-documentation sym 'variable doc))
1775    (when (= *xload-target-unbound-marker*
1776             (xload-symbol-value sym))
1777      (setf (xload-symbol-value sym) val))
1778    (xload-record-source-file sym 'variable)
1779    (let* ((sv (logior *xload-target-fulltag-misc*
1780                       (logandc2 sym *xload-target-fulltagmask*))))
1781      (setf (xload-%svref sv target::symbol.flags-cell)
1782            (ash 
1783             (logior (ash 1 $sym_vbit_special) 
1784                     (ash (xload-%svref sv target::symbol.flags-cell)
1785                          (- *xload-target-fixnumshift*)))
1786             *xload-target-fixnumshift*)))))
1787
1788
1789(xload-copy-faslop $fasl-prog1)
1790
1791(defxloadfaslop $fasl-src (s)
1792  (%cant-epush s)
1793  (let* ((path (%fasl-expr s)))
1794    (setq *xload-loading-file-source-file* path)))
1795
1796(defxloadfaslop $fasl-toplevel-location (s)
1797  (%cant-epush s)
1798  (let* ((location (%fasl-expr s)))
1799    (setq *xload-loading-toplevel-location* location)))
1800
1801;;; Use the offsets in the self-reference table to replace the :self
1802;;; in (movl ($ :self) (% fn)) wih the function's actual address.
1803;;; (x8632 only)
1804(defun xload-fixup-self-references (addr)
1805  (let* ((imm-word-count (xload-u16-at-address
1806                          (+ addr *xload-target-misc-data-offset*))))
1807    (when (logbitp 15 imm-word-count)
1808      (let* ((header (xload-natural-at-address
1809                      (+ addr *xload-target-misc-header-offset*)))
1810             (len (ash header (- target::num-subtag-bits))))
1811        (setq imm-word-count (- len (ldb (byte 15 0) imm-word-count)))))
1812    (do* ((i (- imm-word-count 2) (1- i))
1813          (offset (xload-%fullword-ref addr i) (xload-%fullword-ref addr i)))
1814         ((zerop offset))
1815      (setf (xload-u8-at-address (+ *xload-target-misc-header-offset*
1816                                    addr
1817                                    offset
1818                                    0))
1819                                 (ldb (byte 8 0) addr)
1820            (xload-u8-at-address (+ *xload-target-misc-header-offset*
1821                                    addr
1822                                    offset
1823                                    1))
1824                                 (ldb (byte 8 8) addr)
1825            (xload-u8-at-address (+ *xload-target-misc-header-offset*
1826                                    addr
1827                                    offset
1828                                    2))
1829                                 (ldb (byte 8 16) addr)
1830            (xload-u8-at-address (+ *xload-target-misc-header-offset*
1831                                    addr
1832                                    offset
1833                                    3))
1834                                 (ldb (byte 8 24) addr)))))
1835     
1836(defxloadfaslop $fasl-clfun (s)
1837  (let* ((size-in-elements (%fasl-read-count s))
1838         (size-of-code (%fasl-read-count s)))
1839    (declare (fixnum size-in-elements size-of-code))
1840    (multiple-value-bind (vector v o)
1841        (target-word-size-case
1842         (32 (xload-alloc-fullwords *xload-dynamic-space* *xload-target-fulltag-misc* size-in-elements))
1843         (64 (xload-alloc-doublewords *xload-dynamic-space* *xload-target-fulltag-misc* size-in-elements)))
1844      (declare (fixnum o))
1845      (setf (natural-ref v (+ o *xload-target-misc-header-offset*))
1846            (make-xload-header size-in-elements (xload-target-subtype :function)))
1847      (let* ((function (logior *xload-target-fulltag-for-functions*
1848                               (logandc2 vector *xload-target-fulltagmask*))))
1849        (%epushval s function)
1850        (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*)
1851                            (ash size-of-code *xload-target-fixnumshift*))
1852        (target-arch-case
1853         (:x8632 (xload-fixup-self-references vector)))
1854        (do* ((numconst (- size-in-elements size-of-code))
1855              (i 0 (1+ i))
1856              (constidx size-of-code (1+ constidx)))
1857             ((= i numconst)
1858              (setf (faslstate.faslval s) function))
1859          (declare (fixnum i numconst constidx))
1860          (setf (xload-%svref vector constidx) (%fasl-expr s)))))))
1861
1862(defxloadfaslop $fasl-istruct-cell (s)
1863  (%epushval s (xload-register-istruct-cell (%fasl-expr-preserve-epush s))))
1864
1865
1866
1867(defparameter *xcompile-features* nil)
1868
1869
1870
1871(defun target-Xcompile-directory (target dir &optional force)
1872  (let* ((backend (find-backend target))
1873         (any (not (null force)))
1874         (outpath (merge-pathnames dir (backend-target-fasl-pathname backend)))
1875         (*nx-speed* (max 1 *nx-speed*))
1876         (*nx-safety* (min 1 *nx-safety*)))
1877    (in-development-mode
1878     (dolist (src (sort (directory (merge-pathnames dir "*.lisp"))
1879                        #'string< :key #'namestring)
1880              any)
1881       (let* ((fasl (merge-pathnames outpath  src)))
1882         (when (or force
1883                   (not (probe-file fasl))
1884                   (> (file-write-date src)
1885                      (file-write-date fasl)))
1886           (setq any t)
1887           (compile-file src :target target
1888                         :features *xcompile-features*
1889                         :output-file  fasl 
1890                         :verbose t)))))))
1891
1892(defun target-xcompile-level-0 (target &optional force)
1893  (let* ((backend (or (find-xload-backend target)
1894                      (error "Unknown xload backend: ~s" target)))
1895         ;; Saving doc-strings doesn't work in level-0 (yet.)
1896         (*save-doc-strings* t)
1897         (*fasl-save-doc-strings* t)
1898         (a (target-xcompile-directory target "ccl:level-0;" force))
1899         (b
1900          (dolist (d (backend-xload-info-subdirs backend))
1901            (target-xcompile-directory target d force))))
1902    (or a b)))
1903
1904(defun cross-compile-level-0 (target &optional (recompile t))
1905  (with-cross-compilation-target (target)
1906    (target-xcompile-level-0 target recompile)))
1907   
1908(defun target-Xload-level-0 (target &optional (recompile t))
1909  (let* ((*xload-target-backend* (or (find-xload-backend target)
1910                                     *xload-default-backend*))
1911         (*xload-startup-file* (backend-xload-info-default-startup-file-name
1912                                *xload-target-backend*)))
1913    (in-development-mode
1914     (when recompile
1915       (target-Xcompile-level-0 target (eq recompile :force)))
1916     (let* ((*xload-image-base-address* *xload-image-base-address*)
1917            (*xload-readonly-space-address* *xload-readonly-space-address*)
1918            (*xload-dynamic-space-address* *xload-dynamic-space-address*)
1919            (*xload-target-nil* *xload-target-nil*)
1920            (*xload-target-unbound-marker* *xload-target-unbound-marker*)
1921            (*xload-target-misc-header-offset* *xload-target-misc-header-offset*)
1922            (*xload-target-misc-subtag-offset* *xload-target-misc-subtag-offset*)
1923            (*xload-target-fixnumshift* *xload-target-fixnumshift*)
1924            (*xload-target-fulltag-cons* *xload-target-fulltag-cons*)
1925            (*xload-target-car-offset* *xload-target-car-offset*)
1926            (*xload-target-cdr-offset* *xload-target-cdr-offset*)
1927            (*xload-target-cons-size* *xload-target-cons-size*)
1928            (*xload-target-fulltagmask* *xload-target-fulltagmask*)
1929            (*xload-target-misc-data-offset* *xload-target-misc-data-offset*)
1930            (*xload-target-fulltag-misc* *xload-target-fulltag-misc*)
1931            (*xload-target-subtag-char* *xload-target-subtag-char*)
1932            (*xload-target-charcode-shift* *xload-target-charcode-shift*)
1933            (*xload-target-big-endian* *xload-target-big-endian*)
1934            (*xload-host-big-endian* *xload-host-big-endian*)
1935            (*xload-target-use-code-vectors* *xload-target-use-code-vectors*)
1936            (*xload-target-fulltag-for-symbols* *xload-target-fulltag-for-symbols*)
1937            (*xload-target-fulltag-for-functions* *xload-target-fulltag-for-functions*)
1938            (*xload-target-char-code-limit* *xload-target-char-code-limit*)
1939            (*xload-purespace-reserve* *xload-purespace-reserve*)
1940            (*xload-static-space-address* *xload-static-space-address*))
1941       (setup-xload-target-parameters)
1942       (let* ((*load-verbose* t)
1943              (compiler-backend (find-backend
1944                                 (backend-xload-info-compiler-target-name
1945                                  *xload-target-backend*)))
1946              (wild-fasls (concatenate 'simple-string
1947                                       "*."
1948                                       (pathname-type
1949                                        (backend-target-fasl-pathname
1950                                         compiler-backend))))
1951              (wild-root (merge-pathnames "ccl:level-0;" wild-fasls))
1952              (wild-subdirs
1953               (mapcar #'(lambda (d)
1954                           (merge-pathnames d wild-fasls))
1955                       (backend-xload-info-subdirs *xload-target-backend*)))
1956              (*xload-image-file-name* (backend-xload-info-default-image-name *xload-target-backend*)))
1957         (apply #'xfasload *xload-image-file-name*
1958                (append
1959                 (apply #'append
1960                        (mapcar #'(lambda (d)
1961                                    (sort (directory d) #'string< :key #'namestring))
1962                                wild-subdirs))
1963                 (sort (directory wild-root) #'string< :key #'namestring)))
1964         (format t "~&;Wrote bootstrapping image: ~s" (truename *xload-image-file-name*)))))))
1965
1966(defun Xcompile-directory (dir &optional force)
1967  (target-xcompile-directory (backend-name *host-backend*) dir  force))
1968
1969(defun Xcompile-level-0 (&optional force)
1970  (target-xcompile-level-0 (backend-name *host-backend*) force))
1971
1972(defun xload-level-0 (&optional (recompile t))
1973  (target-xload-level-0 (backend-name *host-backend*) recompile))
1974
1975(defun cross-xload-level-0 (target &optional (recompile t))
1976  (with-cross-compilation-target (target)
1977    (let* ((*target-backend* (find-backend target)))
1978      (target-xload-level-0 target recompile))))
1979
1980
1981(provide "XFASLOAD")
Note: See TracBrowser for help on using the repository browser.