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

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

Merge in mb-coverage-merge branch. No other changes.

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