source: branches/qres/ccl/level-0/nfasload.lisp @ 14261

Last change on this file since 14261 was 13685, checked in by gz, 9 years ago

Store checksum with code coverage info, signal error if try to color a different file than stored; Also while in there, add a restart to coverage coloring to let you skip a file if there are any errors.

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