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

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

Merge in some stuff from working-0711, especially stuff dealing
with early/cold-load istruct cells.

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