source: trunk/ccl/xdump/xfasload.lisp @ 5643

Last change on this file since 5643 was 5643, checked in by gb, 13 years ago

*xload-static-space-address* depends on the backend. ppc64 wants it one
page higher than it has been, to avoid letting unmapped pages get claimed
by the dynamic linker on Darwin.

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