source: trunk/source/level-0/nfasload.lisp @ 10483

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

REGISTER-PACKAGE-REF: use a lock if gethash fails. Ensure that the
package-ref.pkg slot is set if the package exists (see ticket:326).

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