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

Last change on this file since 13070 was 13070, checked in by gz, 11 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 38.5 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), the latter put there by fasloading.
740(defvar *code-covered-functions* nil)
741
742(defun register-code-covered-functions (functions)
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)) *code-covered-functions*))
770    (setf (car a) *loading-file-source-file* (cdr a) functions))
771  nil)
772
773;;; The loader itself
774
775(defun %simple-fasl-set-file-pos (s new)
776  (let* ((fd (faslstate.faslfd s))
777         (posoffset (fd-tell fd)))
778    (if (>= (decf posoffset new) 0)
779      (let* ((count (faslstate.bufcount s)))
780        (if (>= (decf count posoffset ) 0)
781          (progn
782            (setf (faslstate.bufcount s) posoffset)
783            (incf #+32-bit-target (%get-long (faslstate.iobuffer s))
784                  #+64-bit-target (%%get-signed-longlong (faslstate.iobuffer s)
785                                                        0)
786                  count)
787            (return-from %simple-fasl-set-file-pos nil)))))
788    (progn
789      (setf (faslstate.bufcount s) 0)
790      (fd-lseek fd new #$SEEK_SET))))
791
792(defun %simple-fasl-get-file-pos (s)
793  (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s)))
794
795(defparameter *%fasload-verbose* t)
796
797;;; the default fasl file opener sets up the fasl state and checks the header
798(defun %simple-fasl-open (string s)
799  (let* ((ok nil)
800         (fd (fd-open string #$O_RDONLY))
801         (err 0))
802    (declare (fixnum fd))
803    (if (>= fd 0)
804      (if (< (fd-lseek fd 0 #$SEEK_END) 4)
805        (setq err $xnotfasl)
806        (progn
807          (setq err 0)
808          (setf (faslstate.bufcount s) 0
809                (faslstate.faslfd s) fd)
810          (fd-lseek fd 0 #$SEEK_SET)
811          (multiple-value-setq (ok err) (%fasl-check-header s))))
812      (setq err fd))
813    (unless (eql err 0) (setf (faslstate.faslerr s) err))
814    ok))
815
816;;; once the fasl state is set up, this checks the fasl header and
817;;; returns (values ok err)
818(defun %fasl-check-header (s)
819  (let* ((signature (%fasl-read-word s)))
820    (declare (fixnum signature))
821    (if (= signature $fasl-file-id)
822        (values t 0)
823      (if (= signature $fasl-file-id1)
824          (progn
825            (%fasl-set-file-pos s (%fasl-read-long s))
826            (values t 0))
827        (values nil $xnotfasl)))))
828
829(defun %simple-fasl-close (s)
830  (let* ((fd (faslstate.faslfd s)))
831    (when fd (fd-close fd))))
832
833(defun %simple-fasl-init-buffer (s)
834  (declare (ignore s))
835  nil)
836
837(defvar *fasl-api* nil)
838(setf *fasl-api* (%istruct 'faslapi
839                           #'%simple-fasl-open
840                           #'%simple-fasl-close
841                           #'%simple-fasl-init-buffer
842                           #'%simple-fasl-set-file-pos
843                           #'%simple-fasl-get-file-pos
844                           #'%simple-fasl-read-buffer
845                           #'%simple-fasl-read-byte
846                           #'%simple-fasl-read-n-bytes))
847
848(defun %fasl-open (string s)
849  (funcall (faslapi.fasl-open *fasl-api*) string s))
850(defun %fasl-close (s)
851  (funcall (faslapi.fasl-close *fasl-api*) s))
852(defun %fasl-init-buffer (s)
853  (funcall (faslapi.fasl-init-buffer *fasl-api*) s))
854(defun %fasl-set-file-pos (s new)
855  (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new))
856(defun %fasl-get-file-pos (s)
857  (funcall (faslapi.fasl-get-file-pos *fasl-api*) s))
858(defun %fasl-read-buffer (s)
859  (funcall (faslapi.fasl-read-buffer *fasl-api*) s))
860(defun %fasl-read-byte (s)
861  (funcall (faslapi.fasl-read-byte *fasl-api*) s))
862(defun %fasl-read-n-bytes (s ivector byte-offset n)
863  (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n))
864
865(defun %fasload (string &optional (table *fasl-dispatch-table*))
866  ;;(dbg string)
867  (when (and *%fasload-verbose*
868             (not *load-verbose*))
869    (%string-to-stderr ";Loading ") (pdbg string))
870  (let* ((s (%istruct
871             'faslstate
872             nil
873             nil
874             nil
875             nil
876             nil
877             nil
878             nil
879             nil
880             nil
881             nil
882             nil
883             nil
884             nil
885             nil)))
886    (declare (dynamic-extent s))
887    (setf (faslstate.faslfname s) string)
888    (setf (faslstate.fasldispatch s) table)
889    (setf (faslstate.faslversion s) 0)
890    (%stack-block ((buffer (+ target::node-size $fasl-buf-len)))
891      (setf (faslstate.iobuffer s) buffer)
892      (%fasl-init-buffer s)
893      (let* ((parse-string (make-string 255 :element-type 'base-char)))
894        (declare (dynamic-extent parse-string))
895        (setf (faslstate.oldfaslstr s) nil
896              (faslstate.faslstr s) parse-string)
897        (unwind-protect
898             (when (%fasl-open string s)
899               (let* ((nblocks (%fasl-read-word s)))
900                 (declare (fixnum nblocks))
901                 (unless (= nblocks 0)
902                   (let* ((pos (%fasl-get-file-pos s)))
903                     (dotimes (i nblocks)
904                       (%fasl-set-file-pos s pos)
905                       (%fasl-set-file-pos s (%fasl-read-long s))
906                       (incf pos 8)
907                       (let* ((version (%fasl-read-word s)))
908                         (declare (fixnum version))
909                         (if (or (> version (+ #xff00 $fasl-vers))
910                                 (< version (+ #xff00 $fasl-min-vers)))
911                           (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl))
912                           (progn
913                             (setf (faslstate.faslversion s) version)
914                             (%fasl-read-word s) 
915                             (%fasl-read-word s) ; Ignore kernel version stuff
916                             (setf (faslstate.faslevec s) nil
917                                   (faslstate.faslecnt s) 0)
918                             (do* ((op (%fasl-read-byte s) (%fasl-read-byte s)))
919                                  ((= op $faslend))
920                               (declare (fixnum op))
921                               (%fasl-dispatch s op))))))))))
922          (%fasl-close s))
923        (let* ((err (faslstate.faslerr s)))
924          (if err
925            (progn
926              (when *%fasload-verbose*
927                (let* ((herald ";!!Error loading ")
928                       (hlen (length herald))
929                       (len (length string))
930                       (msg (make-string (+ hlen len))))
931                  (declare (dynamic-extent msg))
932                  (%copy-ivector-to-ivector herald 0 msg 0 (* hlen 4))
933                  (%copy-ivector-to-ivector string 0 msg (* hlen 4) (* len 4))
934                  (bug msg)))
935              (values nil err))
936            (values t nil)))))))
937
938
939(defun %new-package-hashtable (size)
940  (%initialize-htab (cons nil (cons 0 0)) size))
941
942(defun %initialize-htab (htab size)
943  (declare (fixnum size))
944  ;; Ensure that "size" is relatively prime to all secondary hash values.
945  ;; If it's small enough, pick the next highest known prime out of the
946  ;; "primsizes" array.  Otherwize, iterate through all all of "hprimes"
947  ;; until we find something relatively prime to all of them.
948  (setq size
949        (if (> size 32749)
950          (do* ((nextsize (logior 1 size) (+ nextsize 2)))
951               ()
952            (declare (fixnum nextsize))
953            (when (dotimes (i 8 t)
954                    (unless (eql 1 (gcd nextsize (uvref #.$hprimes i)))
955                      (return)))
956              (return nextsize)))
957          (dotimes (i (the fixnum (length #.$primsizes)))
958            (let* ((psize (uvref #.$primsizes i)))
959              (declare (fixnum psize))
960              (if (>= psize size) 
961                (return psize))))))
962  (setf (htvec htab) (make-array size #|:initial-element 0|#))
963  (setf (htcount htab) 0)
964  (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3)))))
965  htab)
966
967
968(defun %resize-htab (htab)
969  (declare (optimize (speed 3) (safety 0)))
970  (without-interrupts
971   (let* ((old-vector (htvec htab))
972          (old-len (length old-vector)))
973     (declare (fixnum old-len)
974              (simple-vector old-vector))
975     (let* ((nsyms 0))
976       (declare (fixnum nsyms))
977       (dovector (s old-vector)
978         (when (symbolp s) (incf nsyms)))
979       (%initialize-htab htab 
980                         (the fixnum (+ 
981                                      (the fixnum 
982                                        (+ nsyms (the fixnum (ash nsyms -2))))
983                                      2)))
984       (let* ((new-vector (htvec htab))
985              (nnew 0))
986         (declare (fixnum nnew)
987                  (simple-vector new-vector))
988         (dotimes (i old-len (setf (htcount htab) nnew))
989           (let* ((s (svref old-vector i)))
990               (if (symbolp s)
991                 (let* ((pname (symbol-name s)))
992                   (setf (svref 
993                          new-vector 
994                          (nth-value 
995                           2
996                           (%get-htab-symbol 
997                            pname
998                            (length pname)
999                            htab)))
1000                         s)
1001                   (incf nnew)))))
1002         htab)))))
1003       
1004(defun hash-pname (str len)
1005  (declare (optimize (speed 3) (safety 0)))
1006  (let* ((primary (%pname-hash str len)))
1007    (declare (fixnum primary))
1008    (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7)))))
1009   
1010
1011
1012(defun %get-hashed-htab-symbol (str len htab primary secondary)
1013  (declare (optimize (speed 3) (safety 0))
1014           (fixnum primary secondary len))
1015  (let* ((vec (htvec htab))
1016         (vlen (length vec)))
1017    (declare (fixnum vlen))
1018    (do* ((idx (fast-mod primary vlen) (+ i secondary))
1019          (i idx (if (>= idx vlen) (- idx vlen) idx))
1020          (elt (svref vec i) (svref vec i)))
1021         ((eql elt 0) (values nil nil i))
1022      (declare (fixnum i idx))
1023      (when (symbolp elt)
1024        (let* ((pname (symbol-name elt)))
1025          (if (and 
1026               (= (the fixnum (length pname)) len)
1027               (dotimes (j len t)
1028                 (unless (eq (aref str j) (schar pname j))
1029                   (return))))
1030            (return (values t (%symptr->symbol elt) i))))))))
1031
1032(defun %get-htab-symbol (string len htab)
1033  (declare (optimize (speed 3) (safety 0)))
1034  (multiple-value-bind (p s) (hash-pname string len)
1035    (%get-hashed-htab-symbol string len htab p s)))
1036
1037(defun %find-symbol (string len package)
1038  (declare (optimize (speed 3) (safety 0)))
1039  (multiple-value-bind (found-p sym internal-offset)
1040                       (%get-htab-symbol string len (pkg.itab package))
1041    (if found-p
1042      (values sym :internal internal-offset nil)
1043      (multiple-value-bind (found-p sym external-offset)
1044                           (%get-htab-symbol string len (pkg.etab package))
1045        (if found-p
1046          (values sym :external internal-offset external-offset)
1047          (dolist (p (pkg.used package) (values nil nil internal-offset external-offset))
1048            (multiple-value-bind (found-p sym)
1049                                 (%get-htab-symbol string len (pkg.etab p))
1050              (when found-p
1051                (return (values sym :inherited internal-offset external-offset))))))))))
1052         
1053(defun %htab-add-symbol (symbol htab idx)
1054  (declare (optimize (speed 3) (safety 0)))
1055  (setf (svref (htvec htab) idx) (%symbol->symptr symbol))
1056  (if (>= (incf (the fixnum (htcount htab)))
1057          (the fixnum (htlimit htab)))
1058    (%resize-htab htab))
1059  symbol)
1060
1061(defun %set-symbol-package (symbol package-or-nil)
1062  (declare (optimize (speed 3) (safety 0)))
1063  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1064         (old-pp (%svref symvec target::symbol.package-predicate-cell)))
1065    (if (consp old-pp)
1066      (setf (car old-pp) package-or-nil)
1067      (setf (%svref symvec target::symbol.package-predicate-cell) package-or-nil))))
1068
1069
1070(let* ((force-export-packages (list *keyword-package*))
1071       (force-export-packages-lock (make-lock)))
1072  (defun force-export-packages ()
1073    (with-lock-grabbed (force-export-packages-lock)
1074      (copy-list force-export-packages)))
1075  (defun package-force-export (p)
1076    (let* ((pkg (pkg-arg p)))
1077      (with-lock-grabbed (force-export-packages-lock)
1078        (pushnew pkg force-export-packages))
1079    pkg))
1080  (defun force-export-package-p (pkg)
1081    (with-lock-grabbed (force-export-packages-lock)
1082      (if (memq pkg force-export-packages)
1083        t))))
1084
1085
1086(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export)
1087  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1088         (package-predicate (%svref symvec target::symbol.package-predicate-cell))
1089         (keyword-package (eq package *keyword-package*)))
1090    ;; Set home package
1091    (if package-predicate
1092      (if (listp package-predicate)
1093        (unless (%car package-predicate) (%rplaca package-predicate package)))
1094      (setf (%svref symvec target::symbol.package-predicate-cell) package))
1095    (if (or force-export (force-export-package-p package))
1096      (progn
1097        (%htab-add-symbol symbol (pkg.etab package) external-idx)
1098        (if keyword-package
1099          ;;(define-constant symbol symbol)
1100          (progn
1101            (%set-sym-global-value symbol symbol)
1102            (%symbol-bits symbol 
1103                          (logior (ash 1 $sym_vbit_special) 
1104                                  (ash 1 $sym_vbit_const)
1105                                  (the fixnum (%symbol-bits symbol)))))))
1106      (%htab-add-symbol symbol (pkg.itab package) internal-idx))
1107    (let* ((hook (pkg.intern-hook package)))
1108      (when hook (funcall hook symbol)))
1109    symbol))
1110
1111;;; PNAME must be a simple string!
1112(defun %add-symbol (pname package internal-idx external-idx &optional force-export)
1113  (let* ((sym (make-symbol pname)))
1114    (%insert-symbol sym package internal-idx external-idx force-export)))
1115
1116
1117
1118
1119;;; The initial %toplevel-function% sets %toplevel-function% to NIL;
1120;;; if the %fasload call fails, the lisp should exit (instead of
1121;;; repeating the process endlessly ...
1122
1123
1124(defvar %toplevel-function%
1125  #'(lambda ()
1126      (declare (special *xload-cold-load-functions*
1127                        *xload-cold-load-documentation*
1128                        *xload-startup-file*
1129                        *early-class-cells*))
1130      (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot.
1131      (setq %system-locks% (%cons-population nil))
1132      ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually
1133      ;; do SET-PACKAGE in cold load functions.
1134      (setq %all-packages-lock% (make-read-write-lock))
1135      (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil)))
1136        (funcall f))
1137      (dolist (pair (prog1 *early-class-cells* (setq *early-class-cells* nil)))
1138        (setf (gethash (car pair) %find-classes%) (cdr pair)))
1139      (dolist (p %all-packages%)
1140        (%resize-htab (pkg.itab p))
1141        (%resize-htab (pkg.etab p)))
1142      (dolist (f (prog1 *xload-cold-load-documentation* (setq *xload-cold-load-documentation* nil)))
1143        (apply 'set-documentation f))
1144      ;; Can't bind any specials until this happens
1145      (let* ((max 0))
1146        (%map-areas #'(lambda (symvec)
1147                        (when (= (the fixnum (typecode symvec))
1148                                 target::subtag-symbol)
1149                          (let* ((s (symvector->symptr symvec))
1150                                 (idx (symbol-binding-index s)))
1151                            (when (> idx 0)
1152                              (cold-load-binding-index s))
1153                            (when (> idx max)
1154                              (setq max idx))))))
1155        (%set-binding-index max))
1156      (%fasload *xload-startup-file*)))
1157
Note: See TracBrowser for help on using the repository browser.