source: branches/ia32/level-0/nfasload.lisp @ 8857

Last change on this file since 8857 was 8857, checked in by rme, 13 years ago

New function %UPDATE-SELF-REFERENCES. Call it when fasloading functions
on x8632.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.6 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    #+x8632-target
347    (%update-self-references vector)
348    (do* ((numconst (- size-in-elements size-of-code))
349          (i 0 (1+ i))
350          (constidx size-of-code (1+ constidx)))
351         ((= i numconst)
352          (setf (faslstate.faslval s) function))
353      (declare (fixnum i numconst constidx))
354      (setf (%svref vector constidx) (%fasl-expr s)))))
355   
356   
357(deffaslop $fasl-lfuncall (s)
358  (let* ((fun (%fasl-expr-preserve-epush s)))
359    ;(break "fun = ~s" fun)
360     (%epushval s (funcall fun))))
361
362(deffaslop $fasl-globals (s)
363  (setf (faslstate.faslgsymbols s) (%fasl-expr s)))
364
365(deffaslop $fasl-char (s)
366  (%epushval s (code-char (%fasl-read-count s))))
367
368;;; Deprecated
369(deffaslop $fasl-fixnum (s)
370  (%epushval
371   s
372   (logior (the fixnum (ash (the fixnum (%word-to-int (%fasl-read-word s)))
373                            16))
374           (the fixnum (%fasl-read-word s))) ))
375
376(deffaslop $fasl-s32 (s)
377  (%epushval s (%fasl-read-signed-long s)))
378
379(deffaslop $fasl-s64 (s)
380  (%epushval s (logior (ash (%fasl-read-signed-long s) 32)
381                       (%fasl-read-long s))))
382
383(deffaslop $fasl-dfloat (s)
384  ;; A double-float is a 3-element "misc" object.
385  ;; Element 0 is always 0 and exists solely to keep elements 1 and 2
386  ;; aligned on a 64-bit boundary.
387  (%epushval s (double-float-from-bits (%fasl-read-long s) (%fasl-read-long s))))
388
389(deffaslop $fasl-sfloat (s)
390  (%epushval s (host-single-float-from-unsigned-byte-32 (%fasl-read-long s))))
391
392(deffaslop $fasl-vstr (s)
393  (let* ((n (%fasl-read-count s))
394         (str (make-string (the fixnum n) :element-type 'base-char)))
395    (%epushval s str)
396    (%fasl-read-n-bytes s str 0 n)))
397
398(deffaslop $fasl-nvstr (s)
399  (let* ((n (%fasl-read-count s))
400         (str (make-string (the fixnum n) :element-type 'base-char)))
401    (%epushval s str)
402    (%fasl-read-n-string s str 0 n)))
403
404(deffaslop $fasl-word-fixnum (s)
405  (%epushval s (%word-to-int (%fasl-read-word s))))
406
407(deffaslop $fasl-vmksym (s)
408  (%fasl-vmake-symbol s))
409
410(deffaslop $fasl-nvmksym (s)
411  (%fasl-nvmake-symbol s))
412
413(deffaslop $fasl-vmksym-special (s)
414  (%fasl-vmake-symbol s t))
415
416(deffaslop $fasl-nvmksym-special (s)
417  (%fasl-nvmake-symbol s t))
418
419(deffaslop $fasl-vintern (s)
420  (%fasl-vintern s *package*))
421
422(deffaslop $fasl-nvintern (s)
423  (%fasl-nvintern s *package*))
424
425(deffaslop $fasl-vintern-special (s)
426  (%fasl-vintern s *package* t))
427
428(deffaslop $fasl-nvintern-special (s)
429  (%fasl-nvintern s *package* t))
430
431
432
433
434(deffaslop $fasl-vpkg-intern (s)
435  (let* ((pkg (%fasl-expr-preserve-epush s)))
436    #+paranoia
437    (setq pkg (pkg-arg pkg))
438    (%fasl-vintern s pkg)))
439
440(deffaslop $fasl-nvpkg-intern (s)
441  (let* ((pkg (%fasl-expr-preserve-epush s)))
442    #+paranoia
443    (setq pkg (pkg-arg pkg))
444    (%fasl-nvintern s pkg)))
445
446(deffaslop $fasl-vpkg-intern-special (s)
447  (let* ((pkg (%fasl-expr-preserve-epush s)))
448    #+paranoia
449    (setq pkg (pkg-arg pkg))
450    (%fasl-vintern s pkg t)))
451
452(deffaslop $fasl-nvpkg-intern-special (s)
453  (let* ((pkg (%fasl-expr-preserve-epush s)))
454    #+paranoia
455    (setq pkg (pkg-arg pkg))
456    (%fasl-nvintern s pkg t)))
457
458(deffaslop $fasl-vpkg (s)
459  (%fasl-vpackage s))
460
461(deffaslop $fasl-nvpkg (s)
462  (%fasl-nvpackage s))
463
464(deffaslop $fasl-cons (s)
465  (let* ((cons (%epushval s (cons nil nil))))
466    (declare (type cons cons))
467    (setf (car cons) (%fasl-expr s)
468          (cdr cons) (%fasl-expr s))
469    (setf (faslstate.faslval s) cons)))
470
471(deffaslop $fasl-vlist (s)
472  (%fasl-vlistX s nil))
473
474(deffaslop $fasl-vlist* (s)
475  (%fasl-vlistX s t))
476
477(deffaslop $fasl-nil (s)
478  (%epushval s nil))
479
480(deffaslop $fasl-timm (s)
481  (rlet ((p :int))
482    (setf (%get-long p) (%fasl-read-long s))
483    (%epushval s (%get-unboxed-ptr p))))
484
485(deffaslop $fasl-symfn (s)
486  (%epushval s (%function (%fasl-expr-preserve-epush s))))
487   
488(deffaslop $fasl-eval (s)
489  (%epushval s (eval (%fasl-expr-preserve-epush s))))
490
491;;; For bootstrapping. The real version is cheap-eval in l1-readloop
492(when (not (fboundp 'eval))
493  (defun eval (form)
494    (if (and (listp form)
495             (let ((f (%car form)))
496               (and (symbolp f)
497                    (functionp (fboundp f)))))
498      (apply (%car form) (%cdr form))
499      (error "Can't eval yet: ~s" form))))
500
501
502(deffaslop $fasl-vivec (s)
503  (let* ((subtag (%fasl-read-byte s))
504         (element-count (%fasl-read-count s))
505         (size-in-bytes (subtag-bytes subtag element-count))
506         (vector (%alloc-misc element-count subtag))
507         (byte-offset (or #+32-bit-target (if (= subtag target::subtag-double-float-vector) 4) 0)))
508    (declare (fixnum subtag element-count size-in-bytes))
509    (%epushval s vector)
510    (%fasl-read-n-bytes s vector byte-offset size-in-bytes)
511    vector))
512
513(defun fasl-read-ivector (s subtag)
514  (let* ((element-count (%fasl-read-count s))
515         (size-in-bytes (subtag-bytes subtag element-count))
516         (vector (%alloc-misc element-count subtag)))
517    (declare (fixnum subtag element-count size-in-bytes))
518    (%epushval s vector)
519    (%fasl-read-n-bytes s vector 0 size-in-bytes)
520    vector))
521 
522(deffaslop $fasl-u8-vector (s)
523  (fasl-read-ivector s target::subtag-u8-vector))
524
525(deffaslop $fasl-s8-vector (s)
526  (fasl-read-ivector s target::subtag-s8-vector))
527
528(deffaslop $fasl-u16-vector (s)
529  (fasl-read-ivector s target::subtag-u16-vector))
530
531(deffaslop $fasl-s16-vector (s)
532  (fasl-read-ivector s target::subtag-s16-vector))
533
534(deffaslop $fasl-u32-vector (s)
535  (fasl-read-ivector s target::subtag-u32-vector))
536
537(deffaslop $fasl-s32-vector (s)
538  (fasl-read-ivector s target::subtag-s32-vector))
539
540#+64-bit-target
541(deffaslop $fasl-u64-vector (s)
542  (fasl-read-ivector s target::subtag-u64-vector))
543
544#+64-bit-target
545(deffaslop $fasl-u64-vector (s)
546  (fasl-read-ivector s target::subtag-s64-vector))
547
548(deffaslop $fasl-bit-vector (s)
549  (fasl-read-ivector s target::subtag-bit-vector))
550
551(deffaslop $fasl-bignum32 (s)
552  (let* ((element-count (%fasl-read-count s))
553         (size-in-bytes (* element-count 4))
554         (num (%alloc-misc element-count target::subtag-bignum)))
555    (declare (fixnum subtag element-count size-in-bytes))
556    (%fasl-read-n-bytes s num 0 size-in-bytes)
557    (setq num (%normalize-bignum-2 t num))
558    (%epushval s num)
559    num))
560
561(deffaslop $fasl-single-float-vector (s)
562  (fasl-read-ivector s target::subtag-single-float-vector))
563
564(deffaslop $fasl-double-float-vector (s)
565  #+64-bit-target
566  (fasl-read-ivector s target::subtag-double-float-vector)
567  #+32-bit-target
568  (let* ((element-count (%fasl-read-count s))
569         (size-in-bytes (subtag-bytes target::subtag-double-float-vector
570                                      element-count))
571         (vector (%alloc-misc element-count
572                              target::subtag-double-float-vector)))
573    (declare (fixnum subtag element-count size-in-bytes))
574    (%epushval s vector)
575    (%fasl-read-n-bytes s vector (- target::misc-dfloat-offset
576                                    target::misc-data-offset)
577                        size-in-bytes)
578    vector))
579
580
581
582#-x86-target
583(deffaslop $fasl-code-vector (s)
584  (let* ((element-count (%fasl-read-count s))
585         (size-in-bytes (* 4 element-count))
586         (vector (allocate-typed-vector :code-vector element-count)))
587    (declare (fixnum subtag element-count size-in-bytes))
588    (%epushval s vector)
589    (%fasl-read-n-bytes s vector 0 size-in-bytes)
590    (%make-code-executable vector)
591    vector))
592
593(defun fasl-read-gvector (s subtype)
594  (let* ((n (%fasl-read-count s))
595         (vector (%alloc-misc n subtype)))
596    (declare (fixnum n subtype))
597    (%epushval s vector)
598    (dotimes (i n (setf (faslstate.faslval s) vector))
599      (setf (%svref vector i) (%fasl-expr s)))))
600
601(deffaslop $fasl-vgvec (s)
602  (let* ((subtype (%fasl-read-byte s)))
603    (fasl-read-gvector s subtype)))
604 
605(deffaslop $fasl-ratio (s)
606  (let* ((r (%alloc-misc target::ratio.element-count target::subtag-ratio)))
607    (%epushval s r)
608    (setf (%svref r target::ratio.numer-cell) (%fasl-expr s)
609          (%svref r target::ratio.denom-cell) (%fasl-expr s))
610    (setf (faslstate.faslval s) r)))
611
612(deffaslop $fasl-complex (s)
613  (let* ((c (%alloc-misc target::complex.element-count
614                         target::subtag-complex)))
615    (%epushval s c)
616    (setf (%svref c target::complex.realpart-cell) (%fasl-expr s)
617          (%svref c target::complex.imagpart-cell) (%fasl-expr s))
618    (setf (faslstate.faslval s) c)))
619
620(deffaslop $fasl-t-vector (s)
621  (fasl-read-gvector s target::subtag-simple-vector))
622
623(deffaslop $fasl-function (s)
624  (fasl-read-gvector s target::subtag-function))
625
626(deffaslop $fasl-istruct (s)
627  (fasl-read-gvector s target::subtag-istruct))
628
629(deffaslop $fasl-vector-header (s)
630  (fasl-read-gvector s target::subtag-vectorH))
631
632(deffaslop $fasl-array-header (s)
633  (fasl-read-gvector s target::subtag-arrayH))
634
635
636(deffaslop $fasl-defun (s)
637  (%cant-epush s)
638  (%defun (%fasl-expr s) (%fasl-expr s)))
639
640(deffaslop $fasl-macro (s)
641  (%cant-epush s)
642  (%macro (%fasl-expr s) (%fasl-expr s)))
643
644(deffaslop $fasl-defconstant (s)
645  (%cant-epush s)
646  (%defconstant (%fasl-expr s) (%fasl-expr s) (%fasl-expr s)))
647
648(deffaslop $fasl-defparameter (s)
649  (%cant-epush s)
650  (let* ((sym (%fasl-expr s))
651         (val (%fasl-expr s)))
652    (%defvar sym (%fasl-expr s))
653    (set sym val)))
654
655;;; (defvar var)
656(deffaslop $fasl-defvar (s)
657  (%cant-epush s)
658  (%defvar (%fasl-expr s)))
659
660;;; (defvar var initfom doc)
661(deffaslop $fasl-defvar-init (s)
662  (%cant-epush s)
663  (let* ((sym (%fasl-expr s))
664         (val (%fasl-expr s)))
665    (unless (%defvar sym (%fasl-expr s))
666      (set sym val))))
667
668
669(deffaslop $fasl-prog1 (s)
670  (let* ((val (%fasl-expr s)))
671    (%fasl-expr s)
672    (setf (faslstate.faslval s) val)))
673
674
675
676(deffaslop $fasl-src (s)
677  (%cant-epush s)
678  (let* ((source-file (%fasl-expr s)))
679    ; (format t "~& source-file = ~s" source-file)
680    (setq *loading-file-source-file* source-file)))
681
682(defvar *modules* nil)
683
684;;; Bootstrapping version
685(defun provide (module-name)
686  (push (string module-name) *modules*))
687
688(deffaslop $fasl-provide (s)
689  (provide (%fasl-expr s)))   
690
691
692;;; The loader itself
693
694(defun %simple-fasl-set-file-pos (s new)
695  (let* ((fd (faslstate.faslfd s))
696         (posoffset (fd-tell fd)))
697    (if (>= (decf posoffset new) 0)
698      (let* ((count (faslstate.bufcount s)))
699        (if (>= (decf count posoffset ) 0)
700          (progn
701            (setf (faslstate.bufcount s) posoffset)
702            (incf #+32-bit-target (%get-long (faslstate.iobuffer s))
703                  #+64-bit-target (%%get-signed-longlong (faslstate.iobuffer s)
704                                                        0)
705                  count)
706            (return-from %simple-fasl-set-file-pos nil)))))
707    (progn
708      (setf (faslstate.bufcount s) 0)
709      (fd-lseek fd new #$SEEK_SET))))
710
711(defun %simple-fasl-get-file-pos (s)
712  (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s)))
713
714(defparameter *%fasload-verbose* t)
715
716;;; the default fasl file opener sets up the fasl state and checks the header
717(defun %simple-fasl-open (string s)
718  (let* ((ok nil)
719         (fd (fd-open string #$O_RDONLY))
720         (err 0))
721    (declare (fixnum fd))
722    (if (>= fd 0)
723      (if (< (fd-lseek fd 0 #$SEEK_END) 4)
724        (setq err $xnotfasl)
725        (progn
726          (setq err 0)
727          (setf (faslstate.bufcount s) 0
728                (faslstate.faslfd s) fd)
729          (fd-lseek fd 0 #$SEEK_SET)
730          (multiple-value-setq (ok err) (%fasl-check-header s))))
731      (setq err fd))
732    (unless (eql err 0) (setf (faslstate.faslerr s) err))
733    ok))
734
735;;; once the fasl state is set up, this checks the fasl header and
736;;; returns (values ok err)
737(defun %fasl-check-header (s)
738  (let* ((signature (%fasl-read-word s)))
739    (declare (fixnum signature))
740    (if (= signature $fasl-file-id)
741        (values t 0)
742      (if (= signature $fasl-file-id1)
743          (progn
744            (%fasl-set-file-pos s (%fasl-read-long s))
745            (values t 0))
746        (values nil $xnotfasl)))))
747
748(defun %simple-fasl-close (s)
749  (let* ((fd (faslstate.faslfd s)))
750    (when fd (fd-close fd))))
751
752(defun %simple-fasl-init-buffer (s)
753  (declare (ignore s))
754  nil)
755
756(defvar *fasl-api* nil)
757(setf *fasl-api* (%istruct 'faslapi
758                           #'%simple-fasl-open
759                           #'%simple-fasl-close
760                           #'%simple-fasl-init-buffer
761                           #'%simple-fasl-set-file-pos
762                           #'%simple-fasl-get-file-pos
763                           #'%simple-fasl-read-buffer
764                           #'%simple-fasl-read-byte
765                           #'%simple-fasl-read-n-bytes))
766
767(defun %fasl-open (string s)
768  (funcall (faslapi.fasl-open *fasl-api*) string s))
769(defun %fasl-close (s)
770  (funcall (faslapi.fasl-close *fasl-api*) s))
771(defun %fasl-init-buffer (s)
772  (funcall (faslapi.fasl-init-buffer *fasl-api*) s))
773(defun %fasl-set-file-pos (s new)
774  (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new))
775(defun %fasl-get-file-pos (s)
776  (funcall (faslapi.fasl-get-file-pos *fasl-api*) s))
777(defun %fasl-read-buffer (s)
778  (funcall (faslapi.fasl-read-buffer *fasl-api*) s))
779(defun %fasl-read-byte (s)
780  (funcall (faslapi.fasl-read-byte *fasl-api*) s))
781(defun %fasl-read-n-bytes (s ivector byte-offset n)
782  (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n))
783
784(defun %fasload (string &optional (table *fasl-dispatch-table*))
785  ;;(dbg string)
786  (when (and *%fasload-verbose*
787             (not *load-verbose*))
788    (%string-to-stderr ";Loading ") (pdbg string))
789  (let* ((s (%istruct
790             'faslstate
791             nil
792             nil
793             nil
794             nil
795             nil
796             nil
797             nil
798             nil
799             nil
800             nil
801             nil
802             nil
803             nil
804             nil)))
805    (declare (dynamic-extent s))
806    (setf (faslstate.faslfname s) string)
807    (setf (faslstate.fasldispatch s) table)
808    (setf (faslstate.faslversion s) 0)
809    (%stack-block ((buffer (+ target::node-size $fasl-buf-len)))
810      (setf (faslstate.iobuffer s) buffer)
811      (%fasl-init-buffer s)
812      (let* ((parse-string (make-string 255 :element-type 'base-char)))
813        (declare (dynamic-extent parse-string))
814        (setf (faslstate.oldfaslstr s) nil
815              (faslstate.faslstr s) parse-string)
816        (unwind-protect
817             (when (%fasl-open string s)
818               (let* ((nblocks (%fasl-read-word s)))
819                 (declare (fixnum nblocks))
820                 (unless (= nblocks 0)
821                   (let* ((pos (%fasl-get-file-pos s)))
822                     (dotimes (i nblocks)
823                       (%fasl-set-file-pos s pos)
824                       (%fasl-set-file-pos s (%fasl-read-long s))
825                       (incf pos 8)
826                       (let* ((version (%fasl-read-word s)))
827                         (declare (fixnum version))
828                         (if (or (> version (+ #xff00 $fasl-vers))
829                                 (< version (+ #xff00 $fasl-min-vers)))
830                           (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl))
831                           (progn
832                             (setf (faslstate.faslversion s) version)
833                             (%fasl-read-word s) 
834                             (%fasl-read-word s) ; Ignore kernel version stuff
835                             (setf (faslstate.faslevec s) nil
836                                   (faslstate.faslecnt s) 0)
837                             (do* ((op (%fasl-read-byte s) (%fasl-read-byte s)))
838                                  ((= op $faslend))
839                               (declare (fixnum op))
840                               (%fasl-dispatch s op))))))))))
841          (%fasl-close s))
842        (let* ((err (faslstate.faslerr s)))
843          (if err
844            (progn
845              (when *%fasload-verbose*
846                (let* ((herald ";!!Error loading ")
847                       (hlen (length herald))
848                       (len (length string))
849                       (msg (make-string (+ hlen len))))
850                  (declare (dynamic-extent msg))
851                  (%copy-ivector-to-ivector herald 0 msg 0 (* hlen 4))
852                  (%copy-ivector-to-ivector string 0 msg (* hlen 4) (* len 4))
853                  (bug msg)))
854              (values nil err))
855            (values t nil)))))))
856
857
858(defun %new-package-hashtable (size)
859  (%initialize-htab (cons nil (cons 0 0)) size))
860
861(defun %initialize-htab (htab size)
862  (declare (fixnum size))
863  ;; Ensure that "size" is relatively prime to all secondary hash values.
864  ;; If it's small enough, pick the next highest known prime out of the
865  ;; "primsizes" array.  Otherwize, iterate through all all of "hprimes"
866  ;; until we find something relatively prime to all of them.
867  (setq size
868        (if (> size 32749)
869          (do* ((nextsize (logior 1 size) (+ nextsize 2)))
870               ()
871            (declare (fixnum nextsize))
872            (when (dotimes (i 8 t)
873                    (unless (eql 1 (gcd nextsize (uvref #.$hprimes i)))
874                      (return)))
875              (return nextsize)))
876          (dotimes (i (the fixnum (length #.$primsizes)))
877            (let* ((psize (uvref #.$primsizes i)))
878              (declare (fixnum psize))
879              (if (>= psize size) 
880                (return psize))))))
881  (setf (htvec htab) (make-array size #|:initial-element 0|#))
882  (setf (htcount htab) 0)
883  (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3)))))
884  htab)
885
886
887(defun %resize-htab (htab)
888  (declare (optimize (speed 3) (safety 0)))
889  (without-interrupts
890   (let* ((old-vector (htvec htab))
891          (old-len (length old-vector)))
892     (declare (fixnum old-len)
893              (simple-vector old-vector))
894     (let* ((nsyms 0))
895       (declare (fixnum nsyms))
896       (dovector (s old-vector)
897         (when (symbolp s) (incf nsyms)))
898       (%initialize-htab htab 
899                         (the fixnum (+ 
900                                      (the fixnum 
901                                        (+ nsyms (the fixnum (ash nsyms -2))))
902                                      2)))
903       (let* ((new-vector (htvec htab))
904              (nnew 0))
905         (declare (fixnum nnew)
906                  (simple-vector new-vector))
907         (dotimes (i old-len (setf (htcount htab) nnew))
908           (let* ((s (svref old-vector i)))
909               (if (symbolp s)
910                 (let* ((pname (symbol-name s)))
911                   (setf (svref 
912                          new-vector 
913                          (nth-value 
914                           2
915                           (%get-htab-symbol 
916                            pname
917                            (length pname)
918                            htab)))
919                         s)
920                   (incf nnew)))))
921         htab)))))
922       
923(defun hash-pname (str len)
924  (declare (optimize (speed 3) (safety 0)))
925  (let* ((primary (%pname-hash str len)))
926    (declare (fixnum primary))
927    (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7)))))
928   
929
930
931(defun %get-hashed-htab-symbol (str len htab primary secondary)
932  (declare (optimize (speed 3) (safety 0))
933           (fixnum primary secondary len))
934  (let* ((vec (htvec htab))
935         (vlen (length vec)))
936    (declare (fixnum vlen))
937    (do* ((idx (fast-mod primary vlen) (+ i secondary))
938          (i idx (if (>= idx vlen) (- idx vlen) idx))
939          (elt (svref vec i) (svref vec i)))
940         ((eql elt 0) (values nil nil i))
941      (declare (fixnum i idx))
942      (when (symbolp elt)
943        (let* ((pname (symbol-name elt)))
944          (if (and 
945               (= (the fixnum (length pname)) len)
946               (dotimes (j len t)
947                 (unless (eq (aref str j) (schar pname j))
948                   (return))))
949            (return (values t (%symptr->symbol elt) i))))))))
950
951(defun %get-htab-symbol (string len htab)
952  (declare (optimize (speed 3) (safety 0)))
953  (multiple-value-bind (p s) (hash-pname string len)
954    (%get-hashed-htab-symbol string len htab p s)))
955
956(defun %find-symbol (string len package)
957  (declare (optimize (speed 3) (safety 0)))
958  (multiple-value-bind (found-p sym internal-offset)
959                       (%get-htab-symbol string len (pkg.itab package))
960    (if found-p
961      (values sym :internal internal-offset nil)
962      (multiple-value-bind (found-p sym external-offset)
963                           (%get-htab-symbol string len (pkg.etab package))
964        (if found-p
965          (values sym :external internal-offset external-offset)
966          (dolist (p (pkg.used package) (values nil nil internal-offset external-offset))
967            (multiple-value-bind (found-p sym)
968                                 (%get-htab-symbol string len (pkg.etab p))
969              (when found-p
970                (return (values sym :inherited internal-offset external-offset))))))))))
971         
972(defun %htab-add-symbol (symbol htab idx)
973  (declare (optimize (speed 3) (safety 0)))
974  (setf (svref (htvec htab) idx) (%symbol->symptr symbol))
975  (if (>= (incf (the fixnum (htcount htab)))
976          (the fixnum (htlimit htab)))
977    (%resize-htab htab))
978  symbol)
979
980(defun %set-symbol-package (symbol package-or-nil)
981  (declare (optimize (speed 3) (safety 0)))
982  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
983         (old-pp (%svref symvec target::symbol.package-predicate-cell)))
984    (if (consp old-pp)
985      (setf (car old-pp) package-or-nil)
986      (setf (%svref symvec target::symbol.package-predicate-cell) package-or-nil))))
987
988
989(let* ((force-export-packages (list *keyword-package*))
990       (force-export-packages-lock (make-lock)))
991  (defun force-export-packages ()
992    (with-lock-grabbed (force-export-packages-lock)
993      (copy-list force-export-packages)))
994  (defun package-force-export (p)
995    (let* ((pkg (pkg-arg p)))
996      (with-lock-grabbed (force-export-packages-lock)
997        (pushnew pkg force-export-packages))
998    pkg))
999  (defun force-export-package-p (pkg)
1000    (with-lock-grabbed (force-export-packages-lock)
1001      (if (memq pkg force-export-packages)
1002        t))))
1003
1004
1005(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export)
1006  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1007         (package-predicate (%svref symvec target::symbol.package-predicate-cell))
1008         (keyword-package (eq package *keyword-package*)))
1009    ;; Set home package
1010    (if package-predicate
1011      (if (listp package-predicate)
1012        (unless (%car package-predicate) (%rplaca package-predicate package)))
1013      (setf (%svref symvec target::symbol.package-predicate-cell) package))
1014    (if (or force-export (force-export-package-p package))
1015      (progn
1016        (%htab-add-symbol symbol (pkg.etab package) external-idx)
1017        (if keyword-package
1018          ;;(define-constant symbol symbol)
1019          (progn
1020            (%set-sym-global-value symbol symbol)
1021            (%symbol-bits symbol 
1022                          (logior (ash 1 $sym_vbit_special) 
1023                                  (ash 1 $sym_vbit_const)
1024                                  (the fixnum (%symbol-bits symbol)))))))
1025      (%htab-add-symbol symbol (pkg.itab package) internal-idx))
1026    (let* ((hook (pkg.intern-hook package)))
1027      (when hook (funcall hook symbol)))
1028    symbol))
1029
1030;;; PNAME must be a simple string!
1031(defun %add-symbol (pname package internal-idx external-idx &optional force-export)
1032  (let* ((sym (make-symbol pname)))
1033    (%insert-symbol sym package internal-idx external-idx force-export)))
1034
1035
1036
1037
1038;;; The initial %toplevel-function% sets %toplevel-function% to NIL;
1039;;; if the %fasload call fails, the lisp should exit (instead of
1040;;; repeating the process endlessly ...
1041
1042
1043(defvar %toplevel-function%
1044  #'(lambda ()
1045      (declare (special *xload-cold-load-functions*
1046                        *xload-cold-load-documentation*
1047                        *xload-startup-file*))
1048      (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot.
1049
1050      ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually
1051      ;; do SET-PACKAGE in cold load functions.
1052      (setq %all-packages-lock% (make-read-write-lock))
1053      (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil)))
1054        (funcall f))
1055      (dolist (p %all-packages%)
1056        (%resize-htab (pkg.itab p))
1057        (%resize-htab (pkg.etab p)))
1058      (dolist (f (prog1 *xload-cold-load-documentation* (setq *xload-cold-load-documentation* nil)))
1059        (apply 'set-documentation f))
1060      ;; Can't bind any specials until this happens
1061      (let* ((max 0))
1062        (%map-areas #'(lambda (symvec)
1063                        (when (= (the fixnum (typecode symvec))
1064                                 target::subtag-symbol)
1065                          (let* ((s (symvector->symptr symvec))
1066                                 (idx (symbol-binding-index s)))
1067                            (when (> idx 0)
1068                              (cold-load-binding-index s))
1069                            (when (> idx max)
1070                              (setq max idx))))))
1071        (%set-binding-index max))
1072      (%fasload *xload-startup-file*)))
1073
Note: See TracBrowser for help on using the repository browser.