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

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

Deal with pkg.intern-hook.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 73.0 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                                            nil ;intern-hook
847                                            )))
848                        packages)))
849    (flet ((lookup-clone (p) (or (cdr (assq p alist)) (error "Package ~S not cloned ." p))))
850      (dolist (pair alist alist)
851        (let* ((orig (car pair))
852               (dup (cdr pair)))
853          (setf (pkg.used dup) (mapcar #'lookup-clone (pkg.used orig))
854                (pkg.used-by dup) (mapcar #'lookup-clone (pkg.used-by orig))))))))
855
856;;; Dump each cloned package into dynamic-space; return an alist
857(defun xload-assign-aliased-package-addresses (alist)
858  (let* ((addr-alist (mapcar #'(lambda (pair)
859                                 (let* ((p (cdr pair))
860                                        (v (xload-make-gvector :package (uvsize p))))
861                                   (setf (xload-%svref v pkg.names)
862                                         (xload-save-list (mapcar #'(lambda (n) (xload-save-string n))
863                                                                 (pkg.names p))))
864                                   (cons p v)))
865                             alist)))
866    (flet ((clone->addr (clone)
867             (or (cdr (assq clone addr-alist)) (error "cloned package ~S not found ." clone))))
868      (dolist (pair addr-alist addr-alist)
869        (let* ((p (car pair))
870               (v (cdr pair)))
871          (setf (xload-%svref v pkg.used)
872                (xload-save-list (mapcar #'clone->addr (pkg.used p)))
873                (xload-%svref v pkg.used-by)
874                (xload-save-list (mapcar #'clone->addr (pkg.used-by p)))
875                (xload-%svref v pkg.shadowed) 
876                (xload-save-list (mapcar #'xload-copy-symbol (pkg.shadowed p)))
877                (xload-%svref v pkg.intern-hook)
878                *xload-target-nil*
879                ))))))
880
881
882
883(defun xload-fasload (pathnames)
884  (dolist (path pathnames)
885    (multiple-value-bind (*load-pathname* *load-truename* source-file) (find-load-file (merge-pathnames path))
886      (unless *load-truename*
887        (return (signal-file-error $err-no-file path)))
888      (setq path *load-truename*)
889      (let* ((*readtable* *readtable*)
890             (*package* *ccl-package*)   ; maybe just *package*
891             (*loading-files* (cons path *loading-files*))
892             (*xload-loading-file-source-file* nil)
893             (*loading-file-source-file* (namestring source-file)))
894        (when *load-verbose*
895          (format t "~&;Loading ~S..." *load-pathname*)
896          (force-output))
897        (multiple-value-bind (winp err) (%fasload (native-translated-namestring path) *xload-fasl-dispatch-table*)
898          (if (not winp) (%err-disp err)))))))
899 
900
901
902
903(defun xload-save-htab (htab)
904  (let* ((htvec (car htab))
905         (len (length htvec))
906         (xvec (xload-make-gvector :simple-vector len))
907         (deleted-marker *xload-target-unbound-marker*))
908    (dotimes (i len)
909      (let* ((s (%svref htvec i)))
910        (setf (xload-%svref xvec i)
911              (if s
912                (if (symbolp s)
913                  (or (xload-lookup-symbol s) deleted-marker)
914                  0)
915                (if (= (logand *xload-target-nil* *xload-target-fulltagmask*)
916                       *xload-target-fulltag-for-symbols*)
917                  *xload-target-nil*
918                  (+ *xload-target-nil*
919                     (let* ((arch (backend-target-arch *target-backend*)))
920                       (+ (arch::target-t-offset arch)
921                          (ash 8 (arch::target-word-shift arch))))))))))
922    (xload-make-cons 
923     xvec 
924     (xload-make-cons
925      (xload-integer (cadr htab))
926      (xload-integer (cddr htab))))))
927
928(defun xload-finalize-packages ()
929  (dolist (pair *xload-aliased-package-addresses*)
930    (let* ((p (car pair))
931           (q (cdr pair)))
932      (setf (xload-%svref q pkg.etab) (xload-save-htab (pkg.etab p)))
933      (setf (xload-%svref q pkg.itab) (xload-save-htab (pkg.itab p))))))
934
935(defun xload-get-string (address)
936  (multiple-value-bind (v o) (xload-lookup-address address)
937    (let* ((header (natural-ref v (+ o *xload-target-misc-header-offset*)))
938           (len (ash header (- target::num-subtag-bits)))
939           (str (make-string len))
940           (p (+ o *xload-target-misc-data-offset*)))
941      (case *xload-target-char-code-limit*
942        (256
943         (dotimes (i len str)
944           (setf (schar str i) (code-char (u8-ref v (+ p i))))))
945        (t
946         (dotimes (i len str)
947           (setf (schar str i) (code-char (u32-ref v (+ p (* i 4)))))))))))
948
949               
950(defun xload-save-code-vector (code)
951  (let* ((read-only-p *xload-pure-code-p*)
952         (vlen (uvsize code))
953         (prefix (arch::target-code-vector-prefix (backend-target-arch
954                                                   *target-backend*)))
955         (n (+ (length prefix) vlen)))
956    (declare (fixnum n))
957    (let* ((vector (xload-make-ivector 
958                    (if read-only-p
959                      *xload-readonly-space*
960                      *xload-dynamic-space*)
961                    :code-vector
962                    n))
963           (j -1))
964      (declare (fixnum j))
965      (dotimes (i n)
966        (setf (xload-%fullword-ref vector i)
967              (if prefix
968                (pop prefix)
969                (uvref code (incf j)))))
970      vector)))
971                         
972;;; For debugging
973(defun xload-show-list (l)
974  (labels ((show-list (l)
975             (unless (= l *xload-target-nil*)
976               (format t "#x~x" (xload-car l))
977               (setq l (xload-cdr l))
978               (unless (= l *xload-target-nil*)
979                 (format t " ")
980                 (show-list l)))))
981    (format t "~&(")
982    (show-list l)
983    (format t ")")))
984
985
986(defun xfasload (output-file &rest pathnames)
987  (let* ((*xload-symbols* (make-hash-table :test #'eq))
988         (*xload-symbol-addresses* (make-hash-table :test #'eql))
989         (*xload-spaces* nil)
990         (*xload-readonly-space* (init-xload-space *xload-readonly-space-address* *xload-readonly-space-size* area-readonly))
991         (*xload-dynamic-space* (init-xload-space *xload-dynamic-space-address* *xload-dynamic-space-size* area-dynamic))
992         (*xload-static-space* (init-xload-space *xload-static-space-address* *xload-static-space-size* area-static))
993         (*xload-managed-static-space* (init-xload-space *xload-managed-static-space-address* *xload-managed-static-space-size* area-managed-static))
994                                                 
995         (*xload-package-alist* (xload-clone-packages %all-packages%))
996         (*xload-cold-load-functions* nil)
997         (*xload-cold-load-documentation* nil)
998         (*xload-loading-file-source-file* nil)
999         (*xload-aliased-package-addresses* nil)
1000         (*xload-special-binding-indices*
1001          (make-hash-table :test #'eql))
1002         (*xload-next-special-binding-index*
1003          (length *xload-reserved-special-binding-index-symbols*)))
1004    (funcall (backend-xload-info-static-space-init-function
1005              *xload-target-backend*))
1006    ;; Create %unbound-function% and the package objects in dynamic space,
1007    ;; then fill in the nilreg-relative symbols in static space.
1008    ;; Then start consing ..
1009    (if *xload-target-use-code-vectors*
1010      ;; The undefined-function object is a 1-element simple-vector (not
1011      ;; a function vector).  The code-vector in its 0th element should
1012      ;; report the appropriate error.
1013      (let* ((udf-object (xload-make-gvector :simple-vector 1)))
1014        (setf (xload-%svref udf-object 0) (xload-save-code-vector
1015                                           (backend-xload-info-udf-code
1016                                            *xload-target-backend*))))
1017      (let* ((udf-object (xload-make-gvector :simple-vector 1)))
1018        (setf (xload-%svref udf-object 0) (backend-xload-info-udf-code
1019                                           *xload-target-backend*))))
1020     
1021    (setq *xload-aliased-package-addresses* (xload-assign-aliased-package-addresses *xload-package-alist*))
1022    (dolist (pair (xload-nrs))
1023      (let* ((val-p (consp pair))
1024             (val (if val-p (or (cdr pair) *xload-target-nil*)))
1025             (sym (if val-p (car pair) pair)))
1026        (xload-copy-symbol sym
1027                           :preserve-constantness t
1028                           :space *xload-static-space*)
1029        (when val-p (xload-set sym val))))
1030                                        ; This could be a little less ... procedural.
1031    (xload-set '*package* (xload-package->addr *ccl-package*))
1032    (xload-set '*keyword-package* (xload-package->addr *keyword-package*))
1033    (xload-set '%all-packages% (xload-save-list (mapcar #'cdr *xload-aliased-package-addresses*)))
1034    (xload-set '%unbound-function% (%xload-unbound-function%))
1035    (xload-set '*gc-event-status-bits* (xload-integer 0 #|(ash 1 $gc-integrity-check-bit)|#))
1036    (xload-set '%toplevel-catch% (xload-copy-symbol :toplevel))
1037    (if *xload-target-use-code-vectors*
1038      (xload-set '%closure-code% (xload-save-code-vector
1039                                  (backend-xload-info-closure-trampoline-code
1040                                   *xload-target-backend*)))
1041      (xload-set '%closure-code% *xload-target-nil*))
1042    (let* ((macro-apply-code (funcall
1043                              (backend-xload-info-macro-apply-code-function
1044                               *xload-target-backend*))))
1045
1046      (xload-set '%macro-code%
1047                 (if *xload-target-use-code-vectors*
1048                   (xload-save-code-vector macro-apply-code)
1049                   macro-apply-code)))
1050    (let* ((len (length %builtin-functions%))
1051           (v (xload-make-gvector :simple-vector len)))
1052      (dotimes (i len)
1053        (setf (xload-%svref v i) (xload-copy-symbol (svref %builtin-functions% i))))
1054      (xload-set '%builtin-functions% v))
1055    (xload-copy-symbol '*xload-startup-file*)
1056    (xload-fasload pathnames)
1057    (xload-set '*xload-startup-file*
1058               (xload-save-string *xload-startup-file*))
1059    (let* ((toplevel (xload-symbol-value (xload-lookup-symbol '%toplevel-function%))))     
1060      (when (or (= toplevel *xload-target-unbound-marker*)
1061                (= toplevel *xload-target-nil*))
1062        (warn "~S not set in loading ~S ." '%toplevel-function pathnames)))
1063    (setf (xload-symbol-value (xload-copy-symbol '*xload-cold-load-functions*))
1064          (xload-save-list (setq *xload-cold-load-functions*
1065                                 (nreverse *xload-cold-load-functions*))))
1066    (when *xload-show-cold-load-functions*
1067      (format t "~&cold-load-functions list:")
1068      (xload-show-list (xload-symbol-value (xload-copy-symbol '*xload-cold-load-functions*))))
1069    (setf (xload-symbol-value (xload-copy-symbol '*xload-cold-load-documentation*))
1070          (xload-save-list (setq *xload-cold-load-documentation*
1071                                 (nreverse *xload-cold-load-documentation*))))
1072    (dolist (s *xload-reserved-special-binding-index-symbols*)
1073      (xload-ensure-binding-index (xload-copy-symbol s)))
1074    (xload-finalize-packages)
1075    #+debug
1076    (maphash #'(lambda (addr idx)
1077                 (format t "~&~d: ~s" idx
1078                         (xload-lookup-symbol-address addr)))
1079             *xload-special-binding-indices*)
1080    (xload-dump-image output-file *xload-image-base-address*)))
1081
1082(defun xload-dump-image (output-file heap-start)
1083  (declare (ftype (function (t t list)) write-image-file))
1084  (write-image-file output-file
1085                    heap-start
1086                    (list *xload-readonly-space*
1087                          *xload-static-space*
1088                          *xload-dynamic-space*
1089                          *xload-managed-static-space*)))
1090                   
1091
1092
1093
1094
1095
1096;;; The xloader
1097
1098(xload-copy-faslop $fasl-noop)
1099(xload-copy-faslop $fasl-vetab-alloc)
1100(xload-copy-faslop $fasl-veref)
1101
1102;;; Should error if epush bit set, else push on
1103;;; *xload-cold-load-functions* or something.
1104(defxloadfaslop $fasl-lfuncall (s)
1105  (let* ((fun (%fasl-expr-preserve-epush s)))
1106    (when (faslstate.faslepush s)
1107      (error "Can't call function for value : ~s" fun))
1108    (when *xload-show-cold-load-functions*
1109      (format t "~& cold-load function: #x~x" fun))
1110    (push fun *xload-cold-load-functions*)))
1111
1112(xload-copy-faslop $fasl-globals)        ; what the hell did this ever do ?
1113
1114;;; fasl-char: maybe epush, return target representation of BASE-CHARACTER
1115(defxloadfaslop $fasl-char (s)
1116  (let* ((code (%fasl-read-count s))
1117         (target-char (logior *xload-target-subtag-char*
1118                              (ash code *xload-target-charcode-shift*))))
1119    (%epushval s target-char)))
1120
1121
1122
1123(defxloadfaslop $fasl-dfloat (s)
1124  (%epushval s (xload-make-dfloat *xload-readonly-space* (%fasl-read-long s) (%fasl-read-long s))))
1125
1126(defxloadfaslop $fasl-sfloat (s)
1127  (%epushval s (xload-make-sfloat *xload-readonly-space* (%fasl-read-long s))))
1128
1129(defxloadfaslop $fasl-vstr (s)
1130  (let* ((n (%fasl-read-count s)))
1131    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n)
1132      (%epushval s str)
1133      (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*) n)
1134      str)))
1135
1136(defxloadfaslop $fasl-nvstr (s)
1137  (let* ((n (%fasl-read-count s)))
1138    (multiple-value-bind (str v o) (xload-make-ivector *xload-readonly-space* :simple-string n)
1139      (%epushval s str)
1140      (case *xload-target-char-code-limit*
1141        (256
1142         (dotimes (i n)
1143           (setf (u8-ref v (+ o i *xload-target-misc-data-offset*))
1144                 (%fasl-read-count s))))
1145        (t
1146         (dotimes (i n)
1147           (setf (u32-ref v (+ o (* i 4) *xload-target-misc-data-offset*))
1148                 (%fasl-read-count s)))))
1149      str)))
1150
1151;;; Allegedly deprecated.
1152(defxloadfaslop $fasl-fixnum (s)
1153  (%epushval s (xload-integer
1154                ;; This nonsense converts unsigned %fasl-read-long
1155                ;; result to signed
1156                (rlet ((long :long))
1157                  (setf (%get-long long) (%fasl-read-long s))
1158                  (%get-long long)))))
1159
1160(defxloadfaslop $fasl-word-fixnum (s)
1161  (%epushval s (xload-integer (%word-to-int (%fasl-read-word s)))))
1162
1163(defxloadfaslop $fasl-s32 (s)
1164  (%epushval s (xload-integer (%fasl-read-signed-long s))))
1165
1166(defxloadfaslop $fasl-s64 (s)
1167  (%epushval s (xload-integer (logior (ash (%fasl-read-signed-long s) 32)
1168                                      (%fasl-read-long s))
1169                              2)))
1170
1171(defun xload-set-binding-address (symbol-address idx)
1172  (unless (= *xload-target-fulltag-for-symbols*
1173             (logand symbol-address *xload-target-fulltagmask*))
1174    (error "~& Not a symbol address: #x~x" symbol-address))
1175  (setq symbol-address
1176        (logior *xload-target-fulltag-misc*
1177                (logandc2 symbol-address *xload-target-fulltagmask*)))
1178  (setf (xload-%svref symbol-address target::symbol.binding-index-cell)
1179        (ash idx *xload-target-fixnumshift*))
1180  (setf (gethash symbol-address *xload-special-binding-indices*) idx))
1181
1182(defun xload-ensure-binding-index (symbol-address)
1183  (or (gethash symbol-address *xload-special-binding-indices*)
1184      (let* ((sym (xload-lookup-symbol-address symbol-address))
1185             (pos (position sym *xload-reserved-special-binding-index-symbols*)))
1186        (xload-set-binding-address
1187         symbol-address
1188         (if pos
1189           (1+ pos)
1190           (incf *xload-next-special-binding-index*))))))
1191
1192(defun %xload-fasl-vmake-symbol (s &optional idx)
1193  (let* ((sym (xload-make-symbol (%xload-fasl-vreadstr s))))
1194    (when idx
1195      (xload-ensure-binding-index sym))
1196    (%epushval s sym)))
1197
1198(defun %xload-fasl-nvmake-symbol (s &optional idx)
1199  (let* ((sym (xload-make-symbol (%xload-fasl-nvreadstr s))))
1200    (when idx
1201      (xload-ensure-binding-index sym))
1202    (%epushval s sym)))
1203
1204
1205
1206(defxloadfaslop $fasl-vmksym (s)
1207  (%xload-fasl-vmake-symbol s))
1208
1209(defxloadfaslop $fasl-nvmksym (s)
1210  (%xload-fasl-nvmake-symbol s))
1211
1212(defxloadfaslop $fasl-vmksym-special (s)
1213  (%xload-fasl-vmake-symbol s t))
1214
1215(defxloadfaslop $fasl-nvmksym-special (s)
1216  (%xload-fasl-nvmake-symbol s t))
1217
1218(defun %xload-fasl-vintern (s package &optional idx)
1219  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
1220    (without-interrupts
1221     (multiple-value-bind (cursym access internal external) (%find-symbol str len package)
1222       (unless access
1223         (unless new-p (setq str (%fasl-copystr str len)))
1224         (setq cursym (%add-symbol str package internal external)))
1225       ;; cursym now exists in the load-time world; make sure that it exists
1226       ;; (and is properly "interned" in the world we're making as well)
1227       (let* ((symaddr (xload-copy-symbol cursym)))
1228         (when idx
1229           (xload-ensure-binding-index symaddr))
1230         (%epushval s symaddr))))))
1231
1232(defun %xload-fasl-nvintern (s package &optional idx)
1233  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
1234    (without-interrupts
1235     (multiple-value-bind (cursym access internal external) (%find-symbol str len package)
1236       (unless access
1237         (unless new-p (setq str (%fasl-copystr str len)))
1238         (setq cursym (%add-symbol str package internal external)))
1239       ;; cursym now exists in the load-time world; make sure that it exists
1240       ;; (and is properly "interned" in the world we're making as well)
1241       (let* ((symaddr (xload-copy-symbol cursym)))
1242         (when idx
1243           (xload-ensure-binding-index symaddr))
1244         (%epushval s symaddr))))))
1245
1246
1247(defxloadfaslop $fasl-vintern (s)
1248  (%xload-fasl-vintern s *package*))
1249
1250(defxloadfaslop $fasl-nvintern (s)
1251  (%xload-fasl-nvintern s *package*))
1252
1253(defxloadfaslop $fasl-vintern-special (s)
1254  (%xload-fasl-vintern s *package* t))
1255
1256(defxloadfaslop $fasl-nvintern-special (s)
1257  (%xload-fasl-nvintern s *package* t))
1258
1259(defxloadfaslop $fasl-vpkg-intern (s)
1260  (let* ((addr (%fasl-expr-preserve-epush  s))
1261         (pkg (xload-addr->package addr)))
1262    (%xload-fasl-vintern s pkg)))
1263
1264(defxloadfaslop $fasl-nvpkg-intern (s)
1265  (let* ((addr (%fasl-expr-preserve-epush  s))
1266         (pkg (xload-addr->package addr)))
1267    (%xload-fasl-nvintern s pkg)))
1268
1269(defxloadfaslop $fasl-vpkg-intern-special (s)
1270  (let* ((addr (%fasl-expr-preserve-epush  s))
1271         (pkg (xload-addr->package addr)))
1272    (%xload-fasl-vintern s pkg t)))
1273
1274(defxloadfaslop $fasl-nvpkg-intern-special (s)
1275  (let* ((addr (%fasl-expr-preserve-epush  s))
1276         (pkg (xload-addr->package addr)))
1277    (%xload-fasl-nvintern s pkg t)))
1278
1279(defun %xload-fasl-vpackage (s)
1280  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
1281    (let* ((p (%find-pkg str len)))
1282      (%epushval s (xload-package->addr 
1283                    (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))))
1284
1285(defun %xload-fasl-nvpackage (s)
1286  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
1287    (let* ((p (%find-pkg str len)))
1288      (%epushval s (xload-package->addr 
1289                    (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))))
1290
1291
1292(defxloadfaslop $fasl-vpkg (s)
1293  (%xload-fasl-vpackage s))
1294
1295(defxloadfaslop $fasl-nvpkg (s)
1296  (%xload-fasl-nvpackage s))
1297
1298(defxloadfaslop $fasl-cons (s)
1299  (let* ((cons (%epushval s (xload-make-cons *xload-target-nil* *xload-target-nil*))))
1300    (setf (xload-car cons) (%fasl-expr s)
1301          (xload-cdr cons) (%fasl-expr s))
1302    (setf (faslstate.faslval s) cons)))
1303   
1304
1305(defun %xload-fasl-vlistX (s dotp)
1306  (let* ((len (%fasl-read-count s)))
1307    (declare (fixnum len))
1308    (let* ((val (%epushval s (xload-make-cons *xload-target-nil* *xload-target-nil*)))
1309           (tail val))
1310      (setf (xload-car val) (%fasl-expr s))
1311      (dotimes (i len)
1312        (setf (xload-cdr tail) (setq tail (xload-make-cons  (%fasl-expr s) *xload-target-nil*))))
1313      (if dotp
1314        (setf (xload-cdr tail) (%fasl-expr s)))
1315      (setf (faslstate.faslval s) val))))
1316
1317(defxloadfaslop $fasl-vlist (s)
1318  (%xload-fasl-vlistX s nil))
1319
1320(defxloadfaslop $fasl-vlist* (s)
1321  (%xload-fasl-vlistX s t))
1322
1323(defxloadfaslop $fasl-nil (s)
1324  (%epushval s *xload-target-nil*))
1325
1326(defxloadfaslop $fasl-timm (s)
1327  (let* ((val (%fasl-read-long s)))
1328    #+paranoid (unless (= (logand $typemask val) $t_imm) 
1329                 (error "Bug: expected immediate-tagged object, got ~s ." val))
1330    (%epushval s val)))
1331
1332
1333(defxloadfaslop $fasl-platform (s)
1334  (%cant-epush s)
1335  (let* ((platform (%fasl-expr s))
1336         (backend-name (backend-xload-info-compiler-target-name
1337                                 *xload-target-backend*))
1338         (backend (find-backend backend-name)))
1339    (declare (fixnum platform))
1340    (unless (= platform (ash (backend-target-platform backend)
1341                             *xload-target-fixnumshift*))
1342      (error "Not a ~A fasl file : ~s" backend-name (faslstate.faslfname s)))))
1343
1344
1345(defxloadfaslop $fasl-symfn (s)
1346  (let* ((symaddr (%fasl-expr-preserve-epush s))
1347         (fnobj (xload-%svref symaddr target::symbol.fcell-cell)))
1348    (if (and (= *xload-target-fulltag-misc*
1349                (logand fnobj *xload-target-fulltagmask*))
1350             (= (type-keyword-code :function) (xload-u8-at-address (+ fnobj *xload-target-misc-subtag-offset*))))
1351      (%epushval s fnobj)
1352      (error "symbol at #x~x is unfbound . " symaddr))))
1353
1354(defxloadfaslop $fasl-eval (s)
1355  (let* ((expr (%fasl-expr-preserve-epush s)))
1356    (error "Can't evaluate expression ~s in cold load ." expr)
1357    (%epushval s (eval expr))))         ; could maybe evaluate symbols, constants ...
1358
1359
1360(defun xload-target-subtype (name)
1361  (or
1362   (cdr (assoc name (arch::target-uvector-subtags (backend-target-arch *target-backend*))))
1363   (error "Unknown uvector type name ~s" name)))
1364
1365(defxloadfaslop $fasl-vivec (s)
1366  (let* ((subtag (%fasl-read-byte s))
1367         (element-count (%fasl-read-count s)))
1368    (declare (fixnum subtag))
1369    (multiple-value-bind (vector v o)
1370                         (xload-make-ivector 
1371                          *xload-readonly-space*
1372                          subtag 
1373                          element-count)
1374      (%epushval s vector)
1375      (%fasl-read-n-bytes s v (+ o  *xload-target-misc-data-offset*) (xload-subtag-bytes subtag element-count))
1376      vector)))
1377
1378(defun xfasl-read-ivector (s subtag)
1379  (let* ((element-count (%fasl-read-count s)))
1380    (multiple-value-bind (vector v o)
1381                         (xload-make-ivector 
1382                          *xload-readonly-space*
1383                          subtag 
1384                          element-count)
1385      (%epushval s vector)
1386      (%fasl-read-n-bytes s
1387                          v
1388                          (+ o *xload-target-misc-data-offset*)
1389                          (xload-subtag-bytes subtag element-count))
1390      vector)))
1391
1392(defxloadfaslop $fasl-u8-vector (s)
1393  (xfasl-read-ivector s (xload-target-subtype :unsigned-8-bit-vector)))
1394
1395(defxloadfaslop $fasl-s8-vector (s)
1396  (xfasl-read-ivector s (xload-target-subtype :signed-8-bit-vector)))
1397
1398(defxloadfaslop $fasl-u16-vector (s)
1399  (xfasl-read-ivector s (xload-target-subtype :unsigned-16-bit-vector)))
1400
1401(defxloadfaslop $fasl-s16-vector (s)
1402  (xfasl-read-ivector s (xload-target-subtype :signed-16-bit-vector)))
1403
1404(defxloadfaslop $fasl-u32-vector (s)
1405  (xfasl-read-ivector s (xload-target-subtype :unsigned-32-bit-vector)))
1406
1407(defxloadfaslop $fasl-s32-vector (s)
1408  (xfasl-read-ivector s (xload-target-subtype :signed-32-bit-vector)))
1409
1410
1411;;; We really can't compile 64-bit vectors on a 32-bit host.
1412#+64-bit-target
1413(defxloadfaslop $fasl-u64-vector (s)
1414  (xfasl-read-ivector s (xload-target-subtype :unsigned-64-bit-vector)))
1415
1416#+64-bit-target
1417(defxloadfaslop $fasl-u64-vector (s)
1418  (xfasl-read-ivector s (xload-target-subtype :unsigned-64-bit-vector)))
1419
1420(defxloadfaslop $fasl-bit-vector (s)
1421  (xfasl-read-ivector s (xload-target-subtype :bit-vector)))
1422
1423(defxloadfaslop $fasl-bignum32 (s)
1424  (xfasl-read-ivector s (xload-target-subtype :bignum)))
1425
1426(defxloadfaslop $fasl-single-float-vector (s)
1427  (xfasl-read-ivector s (xload-target-subtype :single-float-vector)))
1428
1429(defxloadfaslop $fasl-double-float-vector (s)
1430  (target-word-size-case
1431   (64 (xfasl-read-ivector s (xload-target-subtype :double-float-vector)))
1432   (32
1433    (let* ((element-count (%fasl-read-count s)))
1434      (multiple-value-bind (vector v o)
1435          (xload-make-ivector 
1436           *xload-readonly-space*
1437           (xload-target-subtype :double-float-vector)
1438           element-count)
1439        (%epushval s vector)
1440        (%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))
1441        vector)))))
1442
1443(defxloadfaslop $fasl-code-vector (s)
1444  (let* ((element-count (%fasl-read-count s))
1445         (subtag (xload-target-subtype :code-vector)))
1446    (multiple-value-bind (vector v o)
1447                         (xload-make-ivector 
1448                          (if (not *xload-pure-code-p*)
1449                            *xload-dynamic-space* 
1450                            *xload-readonly-space*)
1451                          subtag 
1452                          element-count)
1453      (%epushval s vector)
1454      (%fasl-read-n-bytes s v (+ o
1455                                 *xload-target-misc-data-offset*)
1456                          (xload-subtag-bytes subtag element-count))
1457      vector)))
1458
1459(defun xfasl-read-gvector (s subtype)
1460  (declare (fixnum subtype))
1461  (let* ((n (%fasl-read-count s))
1462         (vector (xload-make-gvector subtype n)))
1463    (%epushval s vector)
1464    (dotimes (i n (setf (faslstate.faslval s) vector))
1465      (setf (xload-%svref vector i) (%fasl-expr s)))))
1466 
1467(defxloadfaslop $fasl-vgvec (s)
1468  (let* ((subtype (%fasl-read-byte s)))
1469    (xfasl-read-gvector s subtype)))
1470
1471(defxloadfaslop $fasl-vector-header (s)
1472  (xfasl-read-gvector s (xload-target-subtype :vector-header)))
1473
1474(defxloadfaslop $fasl-array-header (s)
1475  (xfasl-read-gvector s (xload-target-subtype :array-header)))
1476
1477(defxloadfaslop $fasl-ratio (s)
1478  (let* ((r (xload-make-gvector (xload-target-subtype :ratio)
1479                                target::ratio.element-count)))
1480    (%epushval s r)
1481    (setf (xload-%svref r target::ratio.numer-cell) (%fasl-expr s)
1482          (xload-%svref r target::ratio.denom-cell) (%fasl-expr s))
1483    (setf (faslstate.faslval s) r)))
1484
1485(defxloadfaslop $fasl-complex (s)
1486  (let* ((c (xload-make-gvector (xload-target-subtype :complex)
1487                                target::complex.element-count)))
1488    (%epushval s c)
1489    (setf (xload-%svref c target::complex.realpart-cell) (%fasl-expr s)
1490          (xload-%svref c target::complex.imagpart-cell) (%fasl-expr s))
1491    (setf (faslstate.faslval s) c)))
1492
1493
1494
1495(defxloadfaslop $fasl-t-vector (s)
1496  (xfasl-read-gvector s (xload-target-subtype :simple-vector)))
1497
1498(defxloadfaslop $fasl-function (s)
1499  (xfasl-read-gvector s (xload-target-subtype :function)))
1500
1501(defxloadfaslop $fasl-istruct (s)
1502  (xfasl-read-gvector s (xload-target-subtype :istruct)))
1503
1504(defun xload-lfun-name (lf)
1505  (let* ((lfv (logior *xload-target-fulltag-misc*
1506                      (logandc2 lf *xload-target-fulltagmask*)))
1507         (header (xload-%svref lfv -1)))
1508    (unless (= (type-keyword-code :function)
1509               (logand header (1- (ash 1 target::num-subtag-bits))))
1510      (error "Not a function address: ~x" lf))
1511    (let* ((n (ash header (- target::num-subtag-bits))))
1512      (if (> n 2)
1513        (let* ((bits (ash (xload-%svref lfv (1- n))
1514                          (- *xload-target-fixnumshift*))))
1515          (unless (logbitp $lfbits-noname-bit bits)
1516            (xload-%svref lfv (- n 2))))
1517        (error "Teeny, tiny, little function : ~s" lf)))))
1518
1519
1520(defun xload-record-source-file (symaddr indicator)
1521  (when *xload-record-source-file-p*
1522    (when (or (eq indicator 'function)
1523              (eq indicator 'variable))
1524      (let* ((keyaddr (xload-copy-symbol 'bootstrapping-source-files))
1525             (pathaddr (or *xload-loading-file-source-file*
1526                           (if *loading-file-source-file*
1527                             (setq *xload-loading-file-source-file* (xload-save-string *loading-file-source-file*))))))
1528        (when pathaddr
1529          (let* ((keyval (if (eq indicator 'function)
1530                           (xload-make-cons  pathaddr *xload-target-nil*)
1531                           (xload-make-cons
1532                            (xload-make-cons 
1533                             (xload-make-cons  (xload-copy-symbol indicator) pathaddr)
1534                             *xload-target-nil*)
1535                            *xload-target-nil*))))
1536            (setf (xload-symbol-plist symaddr) (xload-make-cons keyaddr keyval))))))))
1537
1538(defun xload-set-documentation (symaddr indicator doc)
1539  ;; Should maybe check further that it's a string
1540  ;; and it would hurt for whatever processes *xload-cold-load-documentation*
1541  ;; to do some checking there as well.
1542  (when (= (the fixnum (logand doc *xload-target-fulltagmask*))
1543           *xload-target-fulltag-misc*)
1544    (push (xload-save-list
1545           (list symaddr
1546                 (xload-copy-symbol indicator)
1547                 doc))
1548          *xload-cold-load-documentation*)))
1549
1550
1551
1552(defxloadfaslop $fasl-defun (s)
1553  (%cant-epush s)
1554  (let* ((fun (%fasl-expr s))
1555         (doc (%fasl-expr s)))
1556    (let* ((sym (xload-lfun-name fun)))
1557      (unless (= doc *xload-target-nil*)
1558        (xload-set-documentation sym 'function doc))
1559      (xload-record-source-file sym 'function)
1560      (xload-fset sym fun))))
1561
1562(defxloadfaslop $fasl-macro (s)
1563  (%cant-epush s)
1564  (let* ((fun (%fasl-expr s))
1565         (doc (%fasl-expr s)))
1566    (let* ((sym (xload-lfun-name fun))
1567           (vector (xload-make-gvector :simple-vector 2)))
1568      (setf (xload-%svref vector 0) (xload-symbol-value (xload-lookup-symbol '%macro-code%))
1569            (xload-%svref vector 1) fun)
1570      (unless (= doc *xload-target-nil*)
1571        (xload-set-documentation sym 'function doc))
1572      (xload-record-source-file sym 'function)
1573      (xload-fset sym vector))))
1574
1575(defxloadfaslop $fasl-defconstant (s)
1576  (%cant-epush s)
1577  (let* ((sym (%fasl-expr s))
1578         (val (%fasl-expr s))
1579         (doc (%fasl-expr s)))
1580    (unless (= doc *xload-target-nil*)
1581      (xload-set-documentation sym 'variable doc))
1582    (xload-record-source-file sym 'variable)
1583    (setf (xload-symbol-value sym) val)
1584    (let* ((sv (logior *xload-target-fulltag-misc*
1585                       (logandc2 sym *xload-target-fulltagmask*))))
1586      (setf (xload-%svref sv target::symbol.flags-cell)
1587            (ash 
1588             (logior (ash 1 $sym_vbit_special) 
1589                     (ash 1 $sym_vbit_const) 
1590                     (ash (xload-%svref sv target::symbol.flags-cell)
1591                        (- *xload-target-fixnumshift*)))
1592             *xload-target-fixnumshift*)))))
1593
1594(defxloadfaslop $fasl-defparameter (s)
1595  (%cant-epush s)
1596  (let* ((sym (%fasl-expr s))
1597         (val (%fasl-expr s))
1598         (doc (%fasl-expr s)))
1599    (unless (= doc *xload-target-nil*)
1600      (xload-set-documentation sym 'variable doc))
1601    (xload-record-source-file sym 'variable)
1602    (setf (xload-symbol-value sym) val)
1603    (let* ((sv (logior *xload-target-fulltag-misc*
1604                       (logandc2 sym *xload-target-fulltagmask*))))
1605      (setf (xload-%svref sv target::symbol.flags-cell)
1606            (ash 
1607             (logior (ash 1 $sym_vbit_special) 
1608                     (ash (xload-%svref sv target::symbol.flags-cell)
1609                          (- *xload-target-fixnumshift*)))
1610             *xload-target-fixnumshift*)))))
1611
1612(defxloadfaslop $fasl-defvar (s)
1613  (%cant-epush s)
1614  (let* ((sym (%fasl-expr s)))
1615    (xload-record-source-file sym 'variable)
1616    (let* ((sv (logior *xload-target-fulltag-misc*
1617                       (logandc2 sym *xload-target-fulltagmask*))))
1618      (setf (xload-%svref sv target::symbol.flags-cell)
1619            (ash 
1620             (logior (ash 1 $sym_vbit_special) 
1621                     (ash (xload-%svref sv target::symbol.flags-cell)
1622                          (- *xload-target-fixnumshift*)))
1623             *xload-target-fixnumshift*)))))
1624
1625(defxloadfaslop $fasl-defvar-init (s)
1626  (%cant-epush s)
1627  (let* ((sym (%fasl-expr s))
1628         (val (%fasl-expr s))
1629         (doc (%fasl-expr s)))
1630    (unless (= doc *xload-target-nil*)
1631      (xload-set-documentation sym 'variable doc))
1632    (when (= *xload-target-unbound-marker*
1633             (xload-symbol-value sym))
1634      (setf (xload-symbol-value sym) val))
1635    (xload-record-source-file sym 'variable)
1636    (let* ((sv (logior *xload-target-fulltag-misc*
1637                       (logandc2 sym *xload-target-fulltagmask*))))
1638      (setf (xload-%svref sv target::symbol.flags-cell)
1639            (ash 
1640             (logior (ash 1 $sym_vbit_special) 
1641                     (ash (xload-%svref sv target::symbol.flags-cell)
1642                          (- *xload-target-fixnumshift*)))
1643             *xload-target-fixnumshift*)))))
1644
1645
1646(xload-copy-faslop $fasl-prog1)
1647
1648(defxloadfaslop $fasl-src (s)
1649  (%cant-epush s)
1650  (let* ((path (%fasl-expr s)))
1651    (setq *xload-loading-file-source-file* path)))
1652
1653(defxloadfaslop $fasl-clfun (s)
1654  (let* ((size-in-elements (%fasl-read-count s))
1655         (size-of-code (%fasl-read-count s)))
1656    (declare (fixnum size-in-elements size-of-code))
1657    (multiple-value-bind (vector v o)
1658        (target-word-size-case
1659         (32 (xload-alloc-fullwords *xload-dynamic-space* *xload-target-fulltag-misc* size-in-elements))
1660         (64 (xload-alloc-doublewords *xload-dynamic-space* *xload-target-fulltag-misc* size-in-elements)))
1661      (declare (fixnum o))
1662      (setf (natural-ref v (+ o *xload-target-misc-header-offset*))
1663            (make-xload-header size-in-elements (xload-target-subtype :function)))
1664      (let* ((function (logior *xload-target-fulltag-for-functions*
1665                               (logandc2 vector *xload-target-fulltagmask*))))
1666        (%epushval s function)
1667        (%fasl-read-n-bytes s v (+ o *xload-target-misc-data-offset*)
1668                            (ash size-of-code *xload-target-fixnumshift*))
1669        (do* ((numconst (- size-in-elements size-of-code))
1670              (i 0 (1+ i))
1671              (constidx size-of-code (1+ constidx)))
1672             ((= i numconst)
1673              (setf (faslstate.faslval s) function))
1674          (declare (fixnum i numconst constidx))
1675          (setf (xload-%svref vector constidx) (%fasl-expr s)))))))
1676
1677
1678(defparameter *xcompile-features* nil)
1679
1680
1681
1682(defun target-Xcompile-directory (target dir &optional force)
1683  (let* ((backend (find-backend target))
1684         (any (not (null force)))
1685         (outpath (merge-pathnames dir (backend-target-fasl-pathname backend))))
1686    (in-development-mode
1687     (dolist (src (sort (directory (merge-pathnames dir "*.lisp"))
1688                        #'string< :key #'namestring)
1689              any)
1690       (let* ((fasl (merge-pathnames outpath  src)))
1691         (when (or force
1692                   (not (probe-file fasl))
1693                   (> (file-write-date src)
1694                      (file-write-date fasl)))
1695           (setq any t)
1696           (compile-file src :target target
1697                         :features *xcompile-features*
1698                         :output-file  fasl 
1699                         :verbose t)))))))
1700
1701(defun target-xcompile-level-0 (target &optional force)
1702  (let* ((backend (or (find-xload-backend target)
1703                      (error "Unknown xload backend: ~s" target)))
1704         ;; Saving doc-strings doesn't work in level-0 (yet.)
1705         (*save-doc-strings* t)
1706         (*fasl-save-doc-strings* t)
1707         (a (target-xcompile-directory target "ccl:level-0;" force))
1708         (b
1709          (dolist (d (backend-xload-info-subdirs backend))
1710            (target-xcompile-directory target d force))))
1711    (or a b)))
1712
1713(defun cross-compile-level-0 (target &optional (recompile t))
1714  (with-cross-compilation-target (target)
1715    (target-xcompile-level-0 target recompile)))
1716   
1717(defun target-Xload-level-0 (target &optional (recompile t))
1718  (let* ((*xload-target-backend* (or (find-xload-backend target)
1719                                     *xload-default-backend*))
1720         (*xload-startup-file* (backend-xload-info-default-startup-file-name
1721                                *xload-target-backend*)))
1722    ;; This just undoes the CLtL1 compatability stuff in
1723    ;; "ccl:library;lisp-package".  If someone's created LISP and/or
1724    ;; USER packages, nuke 'em.
1725    (let* ((user-pkg (find-package "USER"))
1726           (lisp-pkg (find-package "LISP")))
1727      (when (and user-pkg (not (eq user-pkg (find-package "CL-USER"))))
1728        (delete-package user-pkg))
1729      (when (and lisp-pkg (not (eq lisp-pkg (find-package "CL"))))
1730        (delete-package lisp-pkg)))
1731    (in-development-mode
1732     (when recompile
1733       (target-Xcompile-level-0 target (eq recompile :force)))
1734     (let* ((*xload-image-base-address* *xload-image-base-address*)
1735            (*xload-readonly-space-address* *xload-readonly-space-address*)
1736            (*xload-dynamic-space-address* *xload-dynamic-space-address*)
1737            (*xload-target-nil* *xload-target-nil*)
1738            (*xload-target-unbound-marker* *xload-target-unbound-marker*)
1739            (*xload-target-misc-header-offset* *xload-target-misc-header-offset*)
1740            (*xload-target-misc-subtag-offset* *xload-target-misc-subtag-offset*)
1741            (*xload-target-fixnumshift* *xload-target-fixnumshift*)
1742            (*xload-target-fulltag-cons* *xload-target-fulltag-cons*)
1743            (*xload-target-car-offset* *xload-target-car-offset*)
1744            (*xload-target-cdr-offset* *xload-target-cdr-offset*)
1745            (*xload-target-cons-size* *xload-target-cons-size*)
1746            (*xload-target-fulltagmask* *xload-target-fulltagmask*)
1747            (*xload-target-misc-data-offset* *xload-target-misc-data-offset*)
1748            (*xload-target-fulltag-misc* *xload-target-fulltag-misc*)
1749            (*xload-target-subtag-char* *xload-target-subtag-char*)
1750            (*xload-target-charcode-shift* *xload-target-charcode-shift*)
1751            (*xload-target-big-endian* *xload-target-big-endian*)
1752            (*xload-host-big-endian* *xload-host-big-endian*)
1753            (*xload-target-use-code-vectors* *xload-target-use-code-vectors*)
1754            (*xload-target-fulltag-for-symbols* *xload-target-fulltag-for-symbols*)
1755            (*xload-target-fulltag-for-functions* *xload-target-fulltag-for-functions*)
1756            (*xload-target-char-code-limit* *xload-target-char-code-limit*)
1757            (*xload-purespace-reserve* *xload-purespace-reserve*)
1758            (*xload-static-space-address* *xload-static-space-address*))
1759       (setup-xload-target-parameters)
1760       (let* ((*load-verbose* t)
1761              (compiler-backend (find-backend
1762                                 (backend-xload-info-compiler-target-name
1763                                  *xload-target-backend*)))
1764              (wild-fasls (concatenate 'simple-string
1765                                       "*."
1766                                       (pathname-type
1767                                        (backend-target-fasl-pathname
1768                                         compiler-backend))))
1769              (wild-root (merge-pathnames "ccl:level-0;" wild-fasls))
1770              (wild-subdirs
1771               (mapcar #'(lambda (d)
1772                           (merge-pathnames d wild-fasls))
1773                       (backend-xload-info-subdirs *xload-target-backend*)))
1774              (*xload-image-file-name* (backend-xload-info-default-image-name *xload-target-backend*)))
1775         (apply #'xfasload *xload-image-file-name*
1776                (append
1777                 (apply #'append
1778                        (mapcar #'(lambda (d)
1779                                    (sort (directory d) #'string< :key #'namestring))
1780                                wild-subdirs))
1781                 (sort (directory wild-root) #'string< :key #'namestring)))
1782         (format t "~&;Wrote bootstrapping image: ~s" (truename *xload-image-file-name*)))))))
1783
1784(defun Xcompile-directory (dir &optional force)
1785  (target-xcompile-directory (backend-name *host-backend*) dir  force))
1786
1787(defun Xcompile-level-0 (&optional force)
1788  (target-xcompile-level-0 (backend-name *host-backend*) force))
1789
1790(defun xload-level-0 (&optional (recompile t))
1791  (target-xload-level-0 (backend-name *host-backend*) recompile))
1792
1793(defun cross-xload-level-0 (target &optional (recompile t))
1794  (with-cross-compilation-target (target)
1795    (let* ((*target-backend* (find-backend target)))
1796      (target-xload-level-0 target recompile))))
1797
1798
1799(provide "XFASLOAD")
Note: See TracBrowser for help on using the repository browser.