source: trunk/source/xdump/xfasload.lisp @ 14619

Last change on this file since 14619 was 14619, checked in by rme, 9 years ago

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

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