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

Last change on this file since 8836 was 8836, checked in by mb, 14 years ago

Extend compiler and fasloader to store, and set, toplevel source notes.

This allows functions, such as record-source-file, to get the
source-note for the current toplevel form. I'm not yet committing the
(essential) change to record-source-file. This tree can reliably build
itself and, if nothing else, starts up qres.

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