source: branches/ia32/xdump/xfasload.lisp @ 14405

Last change on this file since 14405 was 8212, checked in by rme, 12 years ago

In XLOAD-TARGET-CONSP, add special check for NIL (which is a distinguished
CONS in the x8632 port).

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