source: branches/working-0711-perf/ccl/level-0/nfasload.lisp @ 9507

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

(TYPEP x 'package), since there's no predicate on PACAGEP and it doesn't
exist yet.

Support early registration of class-cells, istruct-cells.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 38.1 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20
21(require "FASLENV" "ccl:xdump;faslenv")
22
23
24(defconstant $primsizes (make-array 23
25                                    :element-type '(unsigned-byte 16)
26                                    :initial-contents
27                                    '(41 61 97 149 223 337 509 769 887 971 1153 1559 1733
28                                      2609 2801 3917 5879 8819 13229 19843 24989 29789 32749)))
29(defconstant $hprimes (make-array 8 
30                                  :element-type '(unsigned-byte 16)
31                                  :initial-contents '(5 7 11 13 17 19 23 29)))
32
33;;; Symbol hash tables: (htvec . (hcount . hlimit))
34
35(defmacro htvec (htab) `(%car ,htab))
36(defmacro htcount (htab) `(%cadr ,htab))
37(defmacro htlimit (htab) `(%cddr ,htab))
38)
39
40(eval-when (:execute :compile-toplevel)
41  (assert (= 80 numfaslops)))
42
43
44
45
46(setq *package-refs* (make-hash-table))
47
48(defvar *fasl-dispatch-table* #80(%bad-fasl))
49
50
51
52
53
54(defun %bad-fasl (s)
55  (error "bad opcode near position ~d in FASL file ~s"
56         (%fasl-get-file-pos s)
57         (faslstate.faslfname s)))
58
59(defun %cant-epush (s)
60  (if (faslstate.faslepush s)
61    (%bad-fasl s)))
62
63(defun %epushval (s val)
64  (setf (faslstate.faslval s) val)
65  (when (faslstate.faslepush s)
66    (setf (svref (faslstate.faslevec s) (faslstate.faslecnt s)) val)
67    (incf (the fixnum (faslstate.faslecnt s))))
68  val)
69
70(defun %simple-fasl-read-buffer (s)
71  (let* ((fd (faslstate.faslfd s))
72         (buffer (faslstate.iobuffer s))
73         (bufptr (%get-ptr buffer)))
74    (declare (dynamic-extent bufptr)
75             (type macptr buffer bufptr pb))
76    (%setf-macptr bufptr (%inc-ptr buffer target::node-size))
77    (setf (%get-ptr buffer) bufptr)
78    (let* ((n (fd-read fd bufptr $fasl-buf-len)))
79      (declare (fixnum n))
80      (if (> n 0)
81        (setf (faslstate.bufcount s) n)
82        (error "Fix this: look at errno, EOF")))))
83
84 
85(defun %simple-fasl-read-byte (s)
86  (loop
87    (let* ((buffer (faslstate.iobuffer s))
88           (bufptr (%get-ptr buffer)))
89      (declare (dynamic-extent bufptr)
90               (type macptr buffer bufptr))
91      (if (>= (the fixnum (decf (the fixnum (faslstate.bufcount s))))
92              0)
93        (return
94         (prog1
95           (%get-unsigned-byte bufptr)
96           (setf (%get-ptr buffer)
97                 (%incf-ptr bufptr))))
98        (%fasl-read-buffer s)))))
99
100(defun %fasl-read-word (s)
101  (the fixnum 
102    (logior (the fixnum (ash (the fixnum (%fasl-read-byte s)) 8))
103            (the fixnum (%fasl-read-byte s)))))
104
105
106(defun %fasl-read-long (s)
107  (logior (ash (%fasl-read-word s) 16) (%fasl-read-word s)))
108
109(defun %fasl-read-signed-long (s)
110  (logior (ash (%word-to-int (%fasl-read-word s)) 16)
111          (%fasl-read-word s)))
112
113
114(defun %fasl-read-count (s)
115  (do* ((val 0)
116        (shift 0 (+ shift 7))
117        (done nil))
118       (done val)
119    (let* ((b (%fasl-read-byte s)))
120      (declare (type (unsigned-byte 8) b))
121      (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift))))))
122
123(defun %simple-fasl-read-n-bytes (s ivector byte-offset n)
124  (declare (fixnum byte-offset n))
125  (do* ()
126       ((= n 0))
127    (let* ((count (faslstate.bufcount s))
128           (buffer (faslstate.iobuffer s))
129           (bufptr (%get-ptr buffer))
130           (nthere (if (< count n) count n)))
131      (declare (dynamic-extent bufptr)
132               (type macptr buffer bufptr)
133               (fixnum count nthere))
134      (if (= nthere 0)
135        (%fasl-read-buffer s)
136        (progn
137          (decf n nthere)
138          (decf (the fixnum (faslstate.bufcount s)) nthere)
139          (%copy-ptr-to-ivector bufptr 0 ivector byte-offset nthere)
140          (incf byte-offset nthere)
141          (setf (%get-ptr buffer)
142                (%incf-ptr bufptr nthere)))))))
143       
144
145(defun %fasl-vreadstr (s)
146  (let* ((nbytes (%fasl-read-count s))
147         (copy t)
148         (n nbytes)
149         (str (faslstate.faslstr s)))
150    (declare (fixnum n nbytes))
151    (if (> n (length str))
152        (setq str (make-string n :element-type 'base-char))
153        (setq copy nil))
154    (%fasl-read-n-bytes s str 0 nbytes)
155    (values str n copy)))
156
157
158(defun %fasl-read-n-string (s string start n)
159  (declare (fixnum start n))
160  (do* ((i start (1+ i))
161        (n n (1- n)))
162       ((<= n 0))
163    (declare (fixnum i n))
164    (setf (schar string i) (code-char (%fasl-read-count s)))))
165
166(defun %fasl-nvreadstr (s)
167  (let* ((nchars (%fasl-read-count s))
168         (copy t)
169         (n nchars)
170         (str (faslstate.faslstr s)))
171    (declare (fixnum n nbytes))
172    (if (> n (length str))
173        (setq str (make-string n :element-type 'base-char))
174        (setq copy nil))
175    (%fasl-read-n-string  s str 0 nchars)
176    (values str n copy)))
177
178(defun %fasl-copystr (str len)
179  (declare (fixnum len))
180  (let* ((new (make-string len :element-type 'base-char)))
181    (declare (simple-base-string new))
182    (declare (optimize (speed 3)(safety 0)))
183    (dotimes (i len new)
184      (setf (schar new i) (schar str i)))))
185
186(defun %fasl-dispatch (s op)
187  (declare (fixnum op)) 
188  (setf (faslstate.faslepush s) (logbitp $fasl-epush-bit op))
189  #+debug
190  (format t "~& dispatch: op = ~d at ~x" (logand op (lognot (ash 1 $fasl-epush-bit)))
191          (1- (%fasl-get-file-pos s)))
192  (funcall (svref (faslstate.fasldispatch s) (logand op (lognot (ash 1 $fasl-epush-bit)))) 
193           s))
194
195(defun %fasl-expr (s)
196  (%fasl-dispatch s (%fasl-read-byte s))
197  (faslstate.faslval s))
198
199(defun %fasl-expr-preserve-epush (s)
200  (let* ((epush (faslstate.faslepush s))
201         (val (%fasl-expr s)))
202    (setf (faslstate.faslepush s) epush)
203    val))
204
205
206(defun %fasl-vmake-symbol (s &optional idx)
207  (declare (fixnum subtype))
208  (let* ((n (%fasl-read-count s))
209         (str (make-string n :element-type 'base-char)))
210    (declare (fixnum n))
211    (%fasl-read-n-bytes s str 0 n)
212    (let* ((sym (make-symbol str)))
213      (when idx (ensure-binding-index sym))
214      (%epushval s sym))))
215
216(defun %fasl-nvmake-symbol (s &optional idx)
217  (declare (fixnum subtype))
218  (let* ((n (%fasl-read-count s))
219         (str (make-string n :element-type 'base-char)))
220    (declare (fixnum n))
221    (%fasl-read-n-string s str 0 n)
222    (let* ((sym (make-symbol str)))
223      (when idx (ensure-binding-index sym))
224      (%epushval s sym))))
225
226(defun %fasl-vintern (s package &optional binding-index)
227  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
228    (with-package-lock (package)
229      (multiple-value-bind (symbol access internal-offset external-offset)
230          (%find-symbol str len package)
231        (unless access
232          (unless new-p (setq str (%fasl-copystr str len)))
233          (setq symbol (%add-symbol str package internal-offset external-offset)))
234        (when binding-index
235          (ensure-binding-index symbol))
236        (%epushval s symbol)))))
237
238(defun %fasl-nvintern (s package &optional binding-index)
239  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
240    (with-package-lock (package)
241      (multiple-value-bind (symbol access internal-offset external-offset)
242          (%find-symbol str len package)
243        (unless access
244          (unless new-p (setq str (%fasl-copystr str len)))
245          (setq symbol (%add-symbol str package internal-offset external-offset)))
246        (when binding-index
247          (ensure-binding-index symbol))
248        (%epushval s symbol)))))
249
250(defvar *package-refs*)
251(setq *package-refs* (make-hash-table :test #'equal))
252
253(defun register-package-ref (name)
254  (or (gethash name *package-refs*)
255      (setf (gethash name *package-refs*) (make-package-ref name))))
256
257(dolist (p %all-packages%)
258  (dolist (name (pkg.names p))
259    (setf (package-ref.pkg (register-package-ref name)) p)))
260
261
262(defun find-package (name)
263  (if (typep  name 'package)
264    name
265    (%find-pkg (string name))))
266
267(defun %pkg-ref-find-package (ref)
268  (package-ref.pkg ref))
269
270(defun set-package (name &aux (pkg (find-package name)))
271  (if pkg
272    (setq *package* pkg)
273    (set-package (%kernel-restart $xnopkg name))))
274
275 
276(defun %find-pkg (name &optional (len (length name)))
277  (declare (fixnum len))
278  (with-package-list-read-lock
279      (dolist (p %all-packages%)
280        (if (dolist (pkgname (pkg.names p))
281              (when (and (= (the fixnum (length pkgname)) len)
282                         (dotimes (i len t)
283                           ;; Aref: allow non-simple strings
284                           (unless (eq (aref name i) (schar pkgname i))
285                             (return))))
286                (return t)))
287          (return p)))))
288
289
290
291(defun pkg-arg (thing &optional deleted-ok)
292  (let* ((xthing (cond ((or (symbolp thing) (typep thing 'character))
293                        (string thing))
294                       ((typep thing 'string)
295                        (ensure-simple-string thing))
296                       (t
297                        thing))))
298    (let* ((typecode (typecode xthing)))
299        (declare (fixnum typecode))
300        (cond ((= typecode target::subtag-package)
301               (if (or deleted-ok (pkg.names xthing))
302                 xthing
303                 (error "~S is a deleted package ." thing)))
304              ((= typecode target::subtag-simple-base-string)
305               (or (%find-pkg xthing)
306                   (%kernel-restart $xnopkg xthing)))
307              (t (report-bad-arg thing 'simple-string))))))
308
309(defun %fasl-vpackage (s)
310  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
311    (let* ((p (%find-pkg str len)))
312      (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
313
314
315(defun %fasl-nvpackage (s)
316  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
317    (let* ((p (%find-pkg str len)))
318      (%epushval s (or p  (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
319
320(defun %fasl-vlistX (s dotp)
321  (let* ((len (%fasl-read-count s)))
322    (declare (fixnum len))
323    (let* ((val (%epushval s (cons nil nil)))
324           (tail val))
325      (declare (type cons val tail))
326      (setf (car val) (%fasl-expr s))
327      (dotimes (i len)
328        (setf (cdr tail) (setq tail (cons (%fasl-expr s) nil))))
329      (if dotp
330        (setf (cdr tail) (%fasl-expr s)))
331      (setf (faslstate.faslval s) val))))
332
333(deffaslop $fasl-noop (s)
334  (%cant-epush s))
335
336
337(deffaslop $fasl-vetab-alloc (s)
338  (%cant-epush s)
339  (setf (faslstate.faslevec s) (make-array (the fixnum (%fasl-read-count s)))
340        (faslstate.faslecnt s) 0))
341
342(deffaslop $fasl-platform (s)
343  (%cant-epush s)
344  (let* ((platform (%fasl-expr s))
345         (host-platform (%get-kernel-global 'host-platform)))
346    (declare (fixnum platform host-platform))
347    (unless (= platform host-platform)
348      (error "Not a native fasl file : ~s" (faslstate.faslfname s)))))
349
350
351(deffaslop $fasl-veref (s)
352  (let* ((idx (%fasl-read-count s)))
353    (declare (fixnum idx))
354    (if (>= idx (the fixnum (faslstate.faslecnt s)))
355      (%bad-fasl s))
356    (%epushval s (svref (faslstate.faslevec s) idx))))
357
358#+x86-target
359;;; Read a "concatenated" lisp function, in which the machine code
360;;; and constants are both contained in the same underlying uvector.
361(deffaslop $fasl-clfun (s)
362  (let* ((size-in-elements (%fasl-read-count s))
363         (size-of-code (%fasl-read-count s))
364         (vector (%alloc-misc size-in-elements target::subtag-function))
365         (function (%function-vector-to-function vector)))
366    (declare (fixnum size-in-elements size-of-code))
367    (%epushval s function)
368    (%fasl-read-n-bytes s vector 0 (ash size-of-code target::word-shift))
369    (do* ((numconst (- size-in-elements size-of-code))
370          (i 0 (1+ i))
371          (constidx size-of-code (1+ constidx)))
372         ((= i numconst)
373          (setf (faslstate.faslval s) function))
374      (declare (fixnum i numconst constidx))
375      (setf (%svref vector constidx) (%fasl-expr s)))))
376   
377   
378(deffaslop $fasl-lfuncall (s)
379  (let* ((fun (%fasl-expr-preserve-epush s)))
380    ;(break "fun = ~s" fun)
381     (%epushval s (funcall fun))))
382
383(deffaslop $fasl-globals (s)
384  (setf (faslstate.faslgsymbols s) (%fasl-expr s)))
385
386(deffaslop $fasl-char (s)
387  (%epushval s (code-char (%fasl-read-count s))))
388
389;;; Deprecated
390(deffaslop $fasl-fixnum (s)
391  (%epushval
392   s
393   (logior (the fixnum (ash (the fixnum (%word-to-int (%fasl-read-word s)))
394                            16))
395           (the fixnum (%fasl-read-word s))) ))
396
397(deffaslop $fasl-s32 (s)
398  (%epushval s (%fasl-read-signed-long s)))
399
400(deffaslop $fasl-s64 (s)
401  (%epushval s (logior (ash (%fasl-read-signed-long s) 32)
402                       (%fasl-read-long s))))
403
404(deffaslop $fasl-dfloat (s)
405  ;; A double-float is a 3-element "misc" object.
406  ;; Element 0 is always 0 and exists solely to keep elements 1 and 2
407  ;; aligned on a 64-bit boundary.
408  (%epushval s (double-float-from-bits (%fasl-read-long s) (%fasl-read-long s))))
409
410(deffaslop $fasl-sfloat (s)
411  (%epushval s (host-single-float-from-unsigned-byte-32 (%fasl-read-long s))))
412
413(deffaslop $fasl-vstr (s)
414  (let* ((n (%fasl-read-count s))
415         (str (make-string (the fixnum n) :element-type 'base-char)))
416    (%epushval s str)
417    (%fasl-read-n-bytes s str 0 n)))
418
419(deffaslop $fasl-nvstr (s)
420  (let* ((n (%fasl-read-count s))
421         (str (make-string (the fixnum n) :element-type 'base-char)))
422    (%epushval s str)
423    (%fasl-read-n-string s str 0 n)))
424
425(deffaslop $fasl-word-fixnum (s)
426  (%epushval s (%word-to-int (%fasl-read-word s))))
427
428(deffaslop $fasl-vmksym (s)
429  (%fasl-vmake-symbol s))
430
431(deffaslop $fasl-nvmksym (s)
432  (%fasl-nvmake-symbol s))
433
434(deffaslop $fasl-vmksym-special (s)
435  (%fasl-vmake-symbol s t))
436
437(deffaslop $fasl-nvmksym-special (s)
438  (%fasl-nvmake-symbol s t))
439
440(deffaslop $fasl-vintern (s)
441  (%fasl-vintern s *package*))
442
443(deffaslop $fasl-nvintern (s)
444  (%fasl-nvintern s *package*))
445
446(deffaslop $fasl-vintern-special (s)
447  (%fasl-vintern s *package* t))
448
449(deffaslop $fasl-nvintern-special (s)
450  (%fasl-nvintern s *package* t))
451
452
453
454
455(deffaslop $fasl-vpkg-intern (s)
456  (let* ((pkg (%fasl-expr-preserve-epush s)))
457    #+paranoia
458    (setq pkg (pkg-arg pkg))
459    (%fasl-vintern s pkg)))
460
461(deffaslop $fasl-nvpkg-intern (s)
462  (let* ((pkg (%fasl-expr-preserve-epush s)))
463    #+paranoia
464    (setq pkg (pkg-arg pkg))
465    (%fasl-nvintern s pkg)))
466
467(deffaslop $fasl-vpkg-intern-special (s)
468  (let* ((pkg (%fasl-expr-preserve-epush s)))
469    #+paranoia
470    (setq pkg (pkg-arg pkg))
471    (%fasl-vintern s pkg t)))
472
473(deffaslop $fasl-nvpkg-intern-special (s)
474  (let* ((pkg (%fasl-expr-preserve-epush s)))
475    #+paranoia
476    (setq pkg (pkg-arg pkg))
477    (%fasl-nvintern s pkg t)))
478
479(deffaslop $fasl-vpkg (s)
480  (%fasl-vpackage s))
481
482(deffaslop $fasl-nvpkg (s)
483  (%fasl-nvpackage s))
484
485(deffaslop $fasl-cons (s)
486  (let* ((cons (%epushval s (cons nil nil))))
487    (declare (type cons cons))
488    (setf (car cons) (%fasl-expr s)
489          (cdr cons) (%fasl-expr s))
490    (setf (faslstate.faslval s) cons)))
491
492(deffaslop $fasl-vlist (s)
493  (%fasl-vlistX s nil))
494
495(deffaslop $fasl-vlist* (s)
496  (%fasl-vlistX s t))
497
498(deffaslop $fasl-nil (s)
499  (%epushval s nil))
500
501(deffaslop $fasl-timm (s)
502  (rlet ((p :int))
503    (setf (%get-long p) (%fasl-read-long s))
504    (%epushval s (%get-unboxed-ptr p))))
505
506(deffaslop $fasl-symfn (s)
507  (%epushval s (%function (%fasl-expr-preserve-epush s))))
508   
509(deffaslop $fasl-eval (s)
510  (%epushval s (eval (%fasl-expr-preserve-epush s))))
511
512;;; For bootstrapping. The real version is cheap-eval in l1-readloop
513(when (not (fboundp 'eval))
514  (defun eval (form)
515    (if (and (listp form)
516             (let ((f (%car form)))
517               (and (symbolp f)
518                    (functionp (fboundp f)))))
519      (do* ((tail (%cdr form) (%cdr tail)))
520           ((null tail) (apply (%car form) (%cdr form)))
521        (let* ((head (car tail)))
522          (when (and (consp head) (eq (car head) 'quote))
523            (setf (car tail) (cadr head)))))
524      (error "Can't eval yet: ~s" form))))
525
526
527(deffaslop $fasl-vivec (s)
528  (let* ((subtag (%fasl-read-byte s))
529         (element-count (%fasl-read-count s))
530         (size-in-bytes (subtag-bytes subtag element-count))
531         (vector (%alloc-misc element-count subtag))
532         (byte-offset (or #+ppc32-target (if (= subtag ppc32::subtag-double-float-vector) 4) 0)))
533    (declare (fixnum subtag element-count size-in-bytes))
534    (%epushval s vector)
535    (%fasl-read-n-bytes s vector byte-offset size-in-bytes)
536    vector))
537
538(defun fasl-read-ivector (s subtag)
539  (let* ((element-count (%fasl-read-count s))
540         (size-in-bytes (subtag-bytes subtag element-count))
541         (vector (%alloc-misc element-count subtag)))
542    (declare (fixnum subtag element-count size-in-bytes))
543    (%epushval s vector)
544    (%fasl-read-n-bytes s vector 0 size-in-bytes)
545    vector))
546 
547(deffaslop $fasl-u8-vector (s)
548  (fasl-read-ivector s target::subtag-u8-vector))
549
550(deffaslop $fasl-s8-vector (s)
551  (fasl-read-ivector s target::subtag-s8-vector))
552
553(deffaslop $fasl-u16-vector (s)
554  (fasl-read-ivector s target::subtag-u16-vector))
555
556(deffaslop $fasl-s16-vector (s)
557  (fasl-read-ivector s target::subtag-s16-vector))
558
559(deffaslop $fasl-u32-vector (s)
560  (fasl-read-ivector s target::subtag-u32-vector))
561
562(deffaslop $fasl-s32-vector (s)
563  (fasl-read-ivector s target::subtag-s32-vector))
564
565#+64-bit-target
566(deffaslop $fasl-u64-vector (s)
567  (fasl-read-ivector s target::subtag-u64-vector))
568
569#+64-bit-target
570(deffaslop $fasl-u64-vector (s)
571  (fasl-read-ivector s target::subtag-s64-vector))
572
573(deffaslop $fasl-bit-vector (s)
574  (fasl-read-ivector s target::subtag-bit-vector))
575
576(deffaslop $fasl-bignum32 (s)
577  (let* ((element-count (%fasl-read-count s))
578         (size-in-bytes (* element-count 4))
579         (num (%alloc-misc element-count target::subtag-bignum)))
580    (declare (fixnum subtag element-count size-in-bytes))
581    (%fasl-read-n-bytes s num 0 size-in-bytes)
582    (setq num (%normalize-bignum-2 t num))
583    (%epushval s num)
584    num))
585
586(deffaslop $fasl-single-float-vector (s)
587  (fasl-read-ivector s target::subtag-single-float-vector))
588
589(deffaslop $fasl-double-float-vector (s)
590  #+64-bit-target
591  (fasl-read-ivector s target::subtag-double-float-vector)
592  #+ppc32-target
593  (let* ((element-count (%fasl-read-count s))
594         (size-in-bytes (subtag-bytes ppc32::subtag-double-float-vector
595                                      element-count))
596         (vector (%alloc-misc element-count
597                              ppc32::subtag-double-float-vector)))
598    (declare (fixnum subtag element-count size-in-bytes))
599    (%epushval s vector)
600    (%fasl-read-n-bytes s vector (- ppc32::misc-dfloat-offset
601                                    ppc32::misc-data-offset)
602                        size-in-bytes)
603    vector))
604
605
606
607#-x86-target
608(deffaslop $fasl-code-vector (s)
609  (let* ((element-count (%fasl-read-count s))
610         (size-in-bytes (* 4 element-count))
611         (vector (allocate-typed-vector :code-vector element-count)))
612    (declare (fixnum subtag element-count size-in-bytes))
613    (%epushval s vector)
614    (%fasl-read-n-bytes s vector 0 size-in-bytes)
615    (%make-code-executable vector)
616    vector))
617
618(defun fasl-read-gvector (s subtype)
619  (let* ((n (%fasl-read-count s))
620         (vector (%alloc-misc n subtype)))
621    (declare (fixnum n subtype))
622    (%epushval s vector)
623    (dotimes (i n (setf (faslstate.faslval s) vector))
624      (setf (%svref vector i) (%fasl-expr s)))))
625
626(deffaslop $fasl-vgvec (s)
627  (let* ((subtype (%fasl-read-byte s)))
628    (fasl-read-gvector s subtype)))
629 
630(deffaslop $fasl-ratio (s)
631  (let* ((r (%alloc-misc target::ratio.element-count target::subtag-ratio)))
632    (%epushval s r)
633    (setf (%svref r target::ratio.numer-cell) (%fasl-expr s)
634          (%svref r target::ratio.denom-cell) (%fasl-expr s))
635    (setf (faslstate.faslval s) r)))
636
637(deffaslop $fasl-complex (s)
638  (let* ((c (%alloc-misc target::complex.element-count
639                         target::subtag-complex)))
640    (%epushval s c)
641    (setf (%svref c target::complex.realpart-cell) (%fasl-expr s)
642          (%svref c target::complex.imagpart-cell) (%fasl-expr s))
643    (setf (faslstate.faslval s) c)))
644
645(deffaslop $fasl-t-vector (s)
646  (fasl-read-gvector s target::subtag-simple-vector))
647
648(deffaslop $fasl-function (s)
649  (fasl-read-gvector s target::subtag-function))
650
651(deffaslop $fasl-istruct (s)
652  (fasl-read-gvector s target::subtag-istruct))
653
654(deffaslop $fasl-vector-header (s)
655  (fasl-read-gvector s target::subtag-vectorH))
656
657(deffaslop $fasl-array-header (s)
658  (fasl-read-gvector s target::subtag-arrayH))
659
660
661(deffaslop $fasl-defun (s)
662  (%cant-epush s)
663  (%defun (%fasl-expr s) (%fasl-expr s)))
664
665(deffaslop $fasl-macro (s)
666  (%cant-epush s)
667  (%macro (%fasl-expr s) (%fasl-expr s)))
668
669(deffaslop $fasl-defconstant (s)
670  (%cant-epush s)
671  (%defconstant (%fasl-expr s) (%fasl-expr s) (%fasl-expr s)))
672
673(deffaslop $fasl-defparameter (s)
674  (%cant-epush s)
675  (let* ((sym (%fasl-expr s))
676         (val (%fasl-expr s)))
677    (%defvar sym (%fasl-expr s))
678    (set sym val)))
679
680;;; (defvar var)
681(deffaslop $fasl-defvar (s)
682  (%cant-epush s)
683  (%defvar (%fasl-expr s)))
684
685;;; (defvar var initfom doc)
686(deffaslop $fasl-defvar-init (s)
687  (%cant-epush s)
688  (let* ((sym (%fasl-expr s))
689         (val (%fasl-expr s)))
690    (unless (%defvar sym (%fasl-expr s))
691      (set sym val))))
692
693
694(deffaslop $fasl-prog1 (s)
695  (let* ((val (%fasl-expr s)))
696    (%fasl-expr s)
697    (setf (faslstate.faslval s) val)))
698
699
700
701(deffaslop $fasl-src (s)
702  (%cant-epush s)
703  (let* ((source-file (%fasl-expr s)))
704    ; (format t "~& source-file = ~s" source-file)
705    (setq *loading-file-source-file* source-file)))
706
707(deffaslop $fasl-toplevel-location (s)
708  (%cant-epush s)
709  (setq *loading-toplevel-location* (%fasl-expr s)))
710
711(defvar *modules* nil)
712
713;;; Bootstrapping version
714(defun provide (module-name)
715  (push (string module-name) *modules*))
716
717(deffaslop $fasl-provide (s)
718  (provide (%fasl-expr s)))
719
720(deffaslop $fasl-istruct-cell (s)
721  (%epushval s (register-istruct-cell (%fasl-expr-preserve-epush s))))
722
723
724
725;;; files compiled with code coverage do this
726;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading.
727(defvar *code-covered-functions* nil)
728
729(defun register-code-covered-functions (functions)
730  ;; unpack the parent-note references - see comment at fcomp-digest-code-notes
731  (labels ((reg (lfun refs)
732             (unless (memq lfun refs)
733               (let* ((lfv (function-to-function-vector lfun))
734                      (start #+ppc-target 0 #+x86-target (%function-code-words lfun))
735                      (refs (cons lfun refs)))
736                 (declare (dynamic-extent refs))
737                 (loop for i from start below (uvsize lfv) as imm = (uvref lfv i)
738                       do (typecase imm
739                            (code-note
740                             (let ((parent (code-note-parent-note imm)))
741                               (when (integerp parent)
742                                 (setf (code-note-parent-note imm) (uvref lfv parent)))))
743                            (function (reg imm refs))))))))
744    (loop for fn across functions do (reg fn nil)))
745  (let ((a (assoc (pathname *loading-file-source-file*)
746                  *code-covered-functions*
747                  :test #'(lambda (p q)
748                            (and (equalp (pathname-name p) (pathname-name q))
749                                 ;; same name, so worth trying harder to match 'em up.
750                                 (or (equal p q)
751                                     (let ((p (full-pathname p)) (q (full-pathname q)))
752                                       (and p q (equalp p q)))
753                                     (let ((p (probe-file p)) (q (probe-file q)))
754                                       (and p q (equalp p q)))))))))
755    (when (null a)
756      (push (setq a (list nil nil)) *code-covered-functions*))
757    (setf (car a) *loading-file-source-file* (cdr a) functions))
758  nil)
759
760;;; The loader itself
761
762(defun %simple-fasl-set-file-pos (s new)
763  (let* ((fd (faslstate.faslfd s))
764         (posoffset (fd-tell fd)))
765    (if (>= (decf posoffset new) 0)
766      (let* ((count (faslstate.bufcount s)))
767        (if (>= (decf count posoffset ) 0)
768          (progn
769            (setf (faslstate.bufcount s) posoffset)
770            (incf #+32-bit-target (%get-long (faslstate.iobuffer s))
771                  #+64-bit-target (%%get-signed-longlong (faslstate.iobuffer s)
772                                                        0)
773                  count)
774            (return-from %simple-fasl-set-file-pos nil)))))
775    (progn
776      (setf (faslstate.bufcount s) 0)
777      (fd-lseek fd new #$SEEK_SET))))
778
779(defun %simple-fasl-get-file-pos (s)
780  (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s)))
781
782(defparameter *%fasload-verbose* t)
783
784;;; the default fasl file opener sets up the fasl state and checks the header
785(defun %simple-fasl-open (string s)
786  (let* ((ok nil)
787         (fd (fd-open string #$O_RDONLY))
788         (err 0))
789    (declare (fixnum fd))
790    (if (>= fd 0)
791      (if (< (fd-lseek fd 0 #$SEEK_END) 4)
792        (setq err $xnotfasl)
793        (progn
794          (setq err 0)
795          (setf (faslstate.bufcount s) 0
796                (faslstate.faslfd s) fd)
797          (fd-lseek fd 0 #$SEEK_SET)
798          (multiple-value-setq (ok err) (%fasl-check-header s))))
799      (setq err fd))
800    (unless (eql err 0) (setf (faslstate.faslerr s) err))
801    ok))
802
803;;; once the fasl state is set up, this checks the fasl header and
804;;; returns (values ok err)
805(defun %fasl-check-header (s)
806  (let* ((signature (%fasl-read-word s)))
807    (declare (fixnum signature))
808    (if (= signature $fasl-file-id)
809        (values t 0)
810      (if (= signature $fasl-file-id1)
811          (progn
812            (%fasl-set-file-pos s (%fasl-read-long s))
813            (values t 0))
814        (values nil $xnotfasl)))))
815
816(defun %simple-fasl-close (s)
817  (let* ((fd (faslstate.faslfd s)))
818    (when fd (fd-close fd))))
819
820(defun %simple-fasl-init-buffer (s)
821  (declare (ignore s))
822  nil)
823
824(defvar *fasl-api* nil)
825(setf *fasl-api* (%istruct 'faslapi
826                           #'%simple-fasl-open
827                           #'%simple-fasl-close
828                           #'%simple-fasl-init-buffer
829                           #'%simple-fasl-set-file-pos
830                           #'%simple-fasl-get-file-pos
831                           #'%simple-fasl-read-buffer
832                           #'%simple-fasl-read-byte
833                           #'%simple-fasl-read-n-bytes))
834
835(defun %fasl-open (string s)
836  (funcall (faslapi.fasl-open *fasl-api*) string s))
837(defun %fasl-close (s)
838  (funcall (faslapi.fasl-close *fasl-api*) s))
839(defun %fasl-init-buffer (s)
840  (funcall (faslapi.fasl-init-buffer *fasl-api*) s))
841(defun %fasl-set-file-pos (s new)
842  (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new))
843(defun %fasl-get-file-pos (s)
844  (funcall (faslapi.fasl-get-file-pos *fasl-api*) s))
845(defun %fasl-read-buffer (s)
846  (funcall (faslapi.fasl-read-buffer *fasl-api*) s))
847(defun %fasl-read-byte (s)
848  (funcall (faslapi.fasl-read-byte *fasl-api*) s))
849(defun %fasl-read-n-bytes (s ivector byte-offset n)
850  (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n))
851
852(defun %fasload (string &optional (table *fasl-dispatch-table*))
853  ;;(dbg string)
854  (when (and *%fasload-verbose*
855             (not *load-verbose*))
856    (%string-to-stderr ";Loading ") (pdbg string))
857  (let* ((s (%istruct
858             'faslstate
859             nil
860             nil
861             nil
862             nil
863             nil
864             nil
865             nil
866             nil
867             nil
868             nil
869             nil
870             nil
871             nil
872             nil)))
873    (declare (dynamic-extent s))
874    (setf (faslstate.faslfname s) string)
875    (setf (faslstate.fasldispatch s) table)
876    (setf (faslstate.faslversion s) 0)
877    (%stack-block ((buffer (+ target::node-size $fasl-buf-len)))
878      (setf (faslstate.iobuffer s) buffer)
879      (%fasl-init-buffer s)
880      (let* ((parse-string (make-string 255 :element-type 'base-char)))
881        (declare (dynamic-extent parse-string))
882        (setf (faslstate.oldfaslstr s) nil
883              (faslstate.faslstr s) parse-string)
884        (unwind-protect
885             (when (%fasl-open string s)
886               (let* ((nblocks (%fasl-read-word s)))
887                 (declare (fixnum nblocks))
888                 (unless (= nblocks 0)
889                   (let* ((pos (%fasl-get-file-pos s)))
890                     (dotimes (i nblocks)
891                       (%fasl-set-file-pos s pos)
892                       (%fasl-set-file-pos s (%fasl-read-long s))
893                       (incf pos 8)
894                       (let* ((version (%fasl-read-word s)))
895                         (declare (fixnum version))
896                         (if (or (> version (+ #xff00 $fasl-vers))
897                                 (< version (+ #xff00 $fasl-min-vers)))
898                           (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl))
899                           (progn
900                             (setf (faslstate.faslversion s) version)
901                             (%fasl-read-word s) 
902                             (%fasl-read-word s) ; Ignore kernel version stuff
903                             (setf (faslstate.faslevec s) nil
904                                   (faslstate.faslecnt s) 0)
905                             (do* ((op (%fasl-read-byte s) (%fasl-read-byte s)))
906                                  ((= op $faslend))
907                               (declare (fixnum op))
908                               (%fasl-dispatch s op))))))))))
909          (%fasl-close s))
910        (let* ((err (faslstate.faslerr s)))
911          (if err
912            (progn
913              (when *%fasload-verbose*
914                (let* ((herald ";!!Error loading ")
915                       (hlen (length herald))
916                       (len (length string))
917                       (msg (make-string (+ hlen len))))
918                  (declare (dynamic-extent msg))
919                  (%copy-ivector-to-ivector herald 0 msg 0 (* hlen 4))
920                  (%copy-ivector-to-ivector string 0 msg (* hlen 4) (* len 4))
921                  (bug msg)))
922              (values nil err))
923            (values t nil)))))))
924
925
926(defun %new-package-hashtable (size)
927  (%initialize-htab (cons nil (cons 0 0)) size))
928
929(defun %initialize-htab (htab size)
930  (declare (fixnum size))
931  ;; Ensure that "size" is relatively prime to all secondary hash values.
932  ;; If it's small enough, pick the next highest known prime out of the
933  ;; "primsizes" array.  Otherwize, iterate through all all of "hprimes"
934  ;; until we find something relatively prime to all of them.
935  (setq size
936        (if (> size 32749)
937          (do* ((nextsize (logior 1 size) (+ nextsize 2)))
938               ()
939            (declare (fixnum nextsize))
940            (when (dotimes (i 8 t)
941                    (unless (eql 1 (gcd nextsize (uvref #.$hprimes i)))
942                      (return)))
943              (return nextsize)))
944          (dotimes (i (the fixnum (length #.$primsizes)))
945            (let* ((psize (uvref #.$primsizes i)))
946              (declare (fixnum psize))
947              (if (>= psize size) 
948                (return psize))))))
949  (setf (htvec htab) (make-array size #|:initial-element 0|#))
950  (setf (htcount htab) 0)
951  (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3)))))
952  htab)
953
954
955(defun %resize-htab (htab)
956  (declare (optimize (speed 3) (safety 0)))
957  (without-interrupts
958   (let* ((old-vector (htvec htab))
959          (old-len (length old-vector)))
960     (declare (fixnum old-len)
961              (simple-vector old-vector))
962     (let* ((nsyms 0))
963       (declare (fixnum nsyms))
964       (dovector (s old-vector)
965         (when (symbolp s) (incf nsyms)))
966       (%initialize-htab htab 
967                         (the fixnum (+ 
968                                      (the fixnum 
969                                        (+ nsyms (the fixnum (ash nsyms -2))))
970                                      2)))
971       (let* ((new-vector (htvec htab))
972              (nnew 0))
973         (declare (fixnum nnew)
974                  (simple-vector new-vector))
975         (dotimes (i old-len (setf (htcount htab) nnew))
976           (let* ((s (svref old-vector i)))
977               (if (symbolp s)
978                 (let* ((pname (symbol-name s)))
979                   (setf (svref 
980                          new-vector 
981                          (nth-value 
982                           2
983                           (%get-htab-symbol 
984                            pname
985                            (length pname)
986                            htab)))
987                         s)
988                   (incf nnew)))))
989         htab)))))
990       
991(defun hash-pname (str len)
992  (declare (optimize (speed 3) (safety 0)))
993  (let* ((primary (%pname-hash str len)))
994    (declare (fixnum primary))
995    (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7)))))
996   
997
998
999(defun %get-hashed-htab-symbol (str len htab primary secondary)
1000  (declare (optimize (speed 3) (safety 0))
1001           (fixnum primary secondary len))
1002  (let* ((vec (htvec htab))
1003         (vlen (length vec)))
1004    (declare (fixnum vlen))
1005    (do* ((idx (fast-mod primary vlen) (+ i secondary))
1006          (i idx (if (>= idx vlen) (- idx vlen) idx))
1007          (elt (svref vec i) (svref vec i)))
1008         ((eql elt 0) (values nil nil i))
1009      (declare (fixnum i idx))
1010      (when (symbolp elt)
1011        (let* ((pname (symbol-name elt)))
1012          (if (and 
1013               (= (the fixnum (length pname)) len)
1014               (dotimes (j len t)
1015                 (unless (eq (aref str j) (schar pname j))
1016                   (return))))
1017            (return (values t (%symptr->symbol elt) i))))))))
1018
1019(defun %get-htab-symbol (string len htab)
1020  (declare (optimize (speed 3) (safety 0)))
1021  (multiple-value-bind (p s) (hash-pname string len)
1022    (%get-hashed-htab-symbol string len htab p s)))
1023
1024(defun %find-symbol (string len package)
1025  (declare (optimize (speed 3) (safety 0)))
1026  (multiple-value-bind (found-p sym internal-offset)
1027                       (%get-htab-symbol string len (pkg.itab package))
1028    (if found-p
1029      (values sym :internal internal-offset nil)
1030      (multiple-value-bind (found-p sym external-offset)
1031                           (%get-htab-symbol string len (pkg.etab package))
1032        (if found-p
1033          (values sym :external internal-offset external-offset)
1034          (dolist (p (pkg.used package) (values nil nil internal-offset external-offset))
1035            (multiple-value-bind (found-p sym)
1036                                 (%get-htab-symbol string len (pkg.etab p))
1037              (when found-p
1038                (return (values sym :inherited internal-offset external-offset))))))))))
1039         
1040(defun %htab-add-symbol (symbol htab idx)
1041  (declare (optimize (speed 3) (safety 0)))
1042  (setf (svref (htvec htab) idx) (%symbol->symptr symbol))
1043  (if (>= (incf (the fixnum (htcount htab)))
1044          (the fixnum (htlimit htab)))
1045    (%resize-htab htab))
1046  symbol)
1047
1048(defun %set-symbol-package (symbol package-or-nil)
1049  (declare (optimize (speed 3) (safety 0)))
1050  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1051         (old-pp (%svref symvec target::symbol.package-predicate-cell)))
1052    (if (consp old-pp)
1053      (setf (car old-pp) package-or-nil)
1054      (setf (%svref symvec target::symbol.package-predicate-cell) package-or-nil))))
1055
1056
1057(let* ((force-export-packages (list *keyword-package*))
1058       (force-export-packages-lock (make-lock)))
1059  (defun force-export-packages ()
1060    (with-lock-grabbed (force-export-packages-lock)
1061      (copy-list force-export-packages)))
1062  (defun package-force-export (p)
1063    (let* ((pkg (pkg-arg p)))
1064      (with-lock-grabbed (force-export-packages-lock)
1065        (pushnew pkg force-export-packages))
1066    pkg))
1067  (defun force-export-package-p (pkg)
1068    (with-lock-grabbed (force-export-packages-lock)
1069      (if (memq pkg force-export-packages)
1070        t))))
1071
1072
1073(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export)
1074  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1075         (package-predicate (%svref symvec target::symbol.package-predicate-cell))
1076         (keyword-package (eq package *keyword-package*)))
1077    ;; Set home package
1078    (if package-predicate
1079      (if (listp package-predicate)
1080        (unless (%car package-predicate) (%rplaca package-predicate package)))
1081      (setf (%svref symvec target::symbol.package-predicate-cell) package))
1082    (if (or force-export (force-export-package-p package))
1083      (progn
1084        (%htab-add-symbol symbol (pkg.etab package) external-idx)
1085        (if keyword-package
1086          ;;(define-constant symbol symbol)
1087          (progn
1088            (%set-sym-global-value symbol symbol)
1089            (%symbol-bits symbol 
1090                          (logior (ash 1 $sym_vbit_special) 
1091                                  (ash 1 $sym_vbit_const)
1092                                  (the fixnum (%symbol-bits symbol)))))))
1093      (%htab-add-symbol symbol (pkg.itab package) internal-idx))
1094    (let* ((hook (pkg.intern-hook package)))
1095      (when hook (funcall hook symbol)))
1096    symbol))
1097
1098;;; PNAME must be a simple string!
1099(defun %add-symbol (pname package internal-idx external-idx &optional force-export)
1100  (let* ((sym (make-symbol pname)))
1101    (%insert-symbol sym package internal-idx external-idx force-export)))
1102
1103
1104
1105
1106;;; The initial %toplevel-function% sets %toplevel-function% to NIL;
1107;;; if the %fasload call fails, the lisp should exit (instead of
1108;;; repeating the process endlessly ...
1109
1110
1111(defvar %toplevel-function%
1112  #'(lambda ()
1113      (declare (special *xload-cold-load-functions*
1114                        *xload-cold-load-documentation*
1115                        *xload-startup-file*
1116                        *early-class-cells*))
1117      (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot.
1118      (setq %system-locks% (%cons-population nil))
1119      ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually
1120      ;; do SET-PACKAGE in cold load functions.
1121      (setq %all-packages-lock% (make-read-write-lock))
1122      (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil)))
1123        (funcall f))
1124      (dolist (pair (prog1 *early-class-cells* (setq *early-class-cells* nil)))
1125        (setf (gethash (car pair) %find-classes%) (cdr pair)))
1126      (dolist (p %all-packages%)
1127        (%resize-htab (pkg.itab p))
1128        (%resize-htab (pkg.etab p)))
1129      (dolist (f (prog1 *xload-cold-load-documentation* (setq *xload-cold-load-documentation* nil)))
1130        (apply 'set-documentation f))
1131      ;; Can't bind any specials until this happens
1132      (let* ((max 0))
1133        (%map-areas #'(lambda (symvec)
1134                        (when (= (the fixnum (typecode symvec))
1135                                 target::subtag-symbol)
1136                          (let* ((s (symvector->symptr symvec))
1137                                 (idx (symbol-binding-index s)))
1138                            (when (> idx 0)
1139                              (cold-load-binding-index s))
1140                            (when (> idx max)
1141                              (setq max idx))))))
1142        (%set-binding-index max))
1143      (%fasload *xload-startup-file*)))
1144
Note: See TracBrowser for help on using the repository browser.