source: branches/purify/source/xdump/xfasload.lisp @ 13218

Last change on this file since 13218 was 13218, checked in by gb, 11 years ago

Just read bytes in $fasl-nvstr.

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