source: branches/working-0711/ccl/xdump/xfasload.lisp @ 11821

Last change on this file since 11821 was 11821, checked in by gz, 12 years ago

Make sure standard optimize settings are in effect when relying on inlining or lack of typechecking, so I can experiment with builds using non-standard global settings

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