source: branches/qres/ccl/xdump/xfasload.lisp @ 15278

Last change on this file since 15278 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

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