source: trunk/ccl/level-0/nfasload.lisp @ 32

Last change on this file since 32 was 32, checked in by gb, 18 years ago

KEYWORD interning sets global value.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.4 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(eval-when (:compile-toplevel :execute)
18
19(require "FASLENV" "ccl:xdump;faslenv")
20#+ppc-target
21(require "PPC-LAPMACROS")
22
23
24
25(defconstant $primsizes (make-array 23
26                                    :element-type 'fixnum
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 (= 50 numfaslops)))
43
44(defvar *fasl-dispatch-table* #50(%bad-fasl))
45
46(defun %bad-fasl (s)
47  (error "bad opcode in FASL file ~s" (faslstate.faslfname s)))
48
49(defun %cant-epush (s)
50  (if (faslstate.faslepush s)
51    (%bad-fasl s)))
52
53(defun %epushval (s val)
54  (setf (faslstate.faslval s) val)
55  (when (faslstate.faslepush s)
56    (setf (svref (faslstate.faslevec s) (faslstate.faslecnt s)) val)
57    (incf (the fixnum (faslstate.faslecnt s))))
58  val)
59
60(defun %simple-fasl-read-buffer (s)
61  (let* ((fd (faslstate.faslfd s))
62         (buffer (faslstate.iobuffer s))
63         (bufptr (%get-ptr buffer)))
64    (declare (dynamic-extent bufptr)
65             (type macptr buffer bufptr pb))
66    (%setf-macptr bufptr (%inc-ptr buffer 4))
67    (setf (%get-ptr buffer) bufptr)
68    (let* ((n (fd-read fd bufptr $fasl-buf-len)))
69      (declare (fixnum n))
70      (if (> n 0)
71        (setf (faslstate.bufcount s) n)
72        (error "Fix this: look at errno, EOF")))))
73
74 
75(defun %simple-fasl-read-byte (s)
76  (loop
77    (let* ((buffer (faslstate.iobuffer s))
78           (bufptr (%get-ptr buffer)))
79      (declare (dynamic-extent bufptr)
80               (type macptr buffer bufptr))
81      (if (>= (the fixnum (decf (the fixnum (faslstate.bufcount s))))
82              0)
83        (return
84         (prog1
85           (%get-unsigned-byte bufptr)
86           (setf (%get-ptr buffer)
87                 (%incf-ptr bufptr))))
88        (%fasl-read-buffer s)))))
89
90(defun %fasl-read-word (s)
91  (the fixnum 
92    (logior (the fixnum (ash (the fixnum (%fasl-read-byte s)) 8))
93            (the fixnum (%fasl-read-byte s)))))
94
95
96
97; This does something much like what COMPOSE-DIGIT does (in the PPC/CMU-bignum
98; code), only we HOPE that compose-digit disappears REAL SOON
99#+ppc-target
100(progn
101  (defppclapfunction %compose-unsigned-fullword ((high arg_y) (low arg_z))
102    (rlwinm imm0 low (- 32 arch::fixnumshift) 16 31)
103    (rlwimi imm0 high (- 16 arch::fixnumshift) 0 15)
104    ; Now have an unsigned fullword in imm0.  Box it.
105    (clrrwi. imm1 imm0 (- arch::least-significant-bit arch::nfixnumtagbits))
106    (box-fixnum arg_z imm0)             ; assume no high bits set.
107    (beqlr+)
108    (ba .SPmakeu32))
109
110 
111  (defppclapfunction %compose-signed-fixnum ((high arg_y) (low arg_z))
112    (rlwinm imm0 low (- 32 arch::fixnumshift) 16 31)
113    (rlwimi imm0 high (- 16 arch::fixnumshift) 0 15)
114    ; Now have an unsigned fullword in imm0.  Box it.
115    (box-fixnum arg_z imm0)
116    (blr))
117)
118
119#+sparc-target
120(progn
121  (defsparclapfunction %compose-unsigned-fullword ((%high %arg_y) (%low %arg_z))
122    (set #xffff %imm1)
123    (unbox-fixnum %low %imm0)
124    (and %imm1 %imm0 %imm0)
125    (sll %high (- 16 arch::fixnumshift) %imm1)
126    (or %imm1 %imm0 %imm0)
127    (box-unsigned-byte-32 %imm0 %imm1 %arg_z)
128    (retl)
129     (nop))
130
131  (defsparclapfunction %compose-signed-fixnum ((%high %arg_y) (%low %arg_z))
132    (set #xffff %imm1)
133    (unbox-fixnum %low %imm0)
134    (and %imm1 %imm0 %imm0)
135    (sll %high (- 16 arch::fixnumshift) %imm1)
136    (or %imm1 %imm0 %imm0)
137    (retl)
138     (box-fixnum %imm0 %arg_z))
139)
140
141(defun %fasl-read-long (s)
142  (%compose-unsigned-fullword (%fasl-read-word s) (%fasl-read-word s)))
143
144
145
146(defun %fasl-read-size (s)
147  (let* ((size (%fasl-read-byte s)))
148    (declare (integer size))
149    (when (= size #xFF)
150      (setq size (%fasl-read-word s))
151      (if (= size #xFFFF)
152        (setq size (%fasl-read-long s))))
153    size))
154
155(defun %simple-fasl-read-n-bytes (s ivector byte-offset n)
156  (declare (fixnum byte-offset n))
157  (do* ()
158       ((= n 0))
159    (let* ((count (faslstate.bufcount s))
160           (buffer (faslstate.iobuffer s))
161           (bufptr (%get-ptr buffer))
162           (nthere (if (< count n) count n)))
163      (declare (dynamic-extent bufptr)
164               (type macptr buffer bufptr)
165               (fixnum count nthere))
166      (if (= nthere 0)
167        (%fasl-read-buffer s)
168        (progn
169          (decf n nthere)
170          (decf (the fixnum (faslstate.bufcount s)) nthere)
171          (%copy-ptr-to-ivector bufptr 0 ivector byte-offset nthere)
172          (incf byte-offset nthere)
173          (setf (%get-ptr buffer)
174                (%incf-ptr bufptr nthere)))))))
175       
176
177(defun %fasl-readstr (s &optional ignore)
178  (declare (fixnum subtype) (ignore ignore))
179  (let* ((nbytes (%fasl-read-size s))
180         (copy t)
181         (n nbytes)
182         (str (faslstate.faslstr s)))
183    (declare (fixnum n nbytes))
184    (if (> n (length str))
185        (setq str (make-string n :element-type 'base-char))
186        (setq copy nil))
187    (%fasl-read-n-bytes s str 0 nbytes)
188    (values str n copy)))
189
190(defun %fasl-copystr (str len)
191  ; IS THIS OK?
192  (declare (fixnum len))
193  (let* ((new (make-string len :element-type 'base-char)))
194    (declare (simple-base-string new))
195    (declare (optimize (speed 3)(safety 0)))
196    (dotimes (i len new)
197      (setf (schar new i) (schar str i)))))
198
199(defun %fasl-dispatch (s op)
200  (declare (fixnum op))
201  (setf (faslstate.faslepush s) (logbitp $fasl-epush-bit op))
202  ;(format t "~& dispatch: op = ~d" (logand op (lognot (ash 1 $fasl-epush-bit))))
203  (funcall (svref (faslstate.fasldispatch s) (logand op (lognot (ash 1 $fasl-epush-bit)))) 
204           s))
205
206(defun %fasl-expr (s)
207  (%fasl-dispatch s (%fasl-read-byte s))
208  (faslstate.faslval s))
209
210(defun %fasl-expr-preserve-epush (s)
211  (let* ((epush (faslstate.faslepush s))
212         (val (%fasl-expr s)))
213    (setf (faslstate.faslepush s) epush)
214    val))
215
216(defun %fasl-make-symbol (s ignore)
217  (declare (fixnum subtype) (ignore ignore))
218  (let* ((n (%fasl-read-size s))
219         (str (make-string n :element-type 'base-char)))
220    (declare (fixnum n))
221    (%fasl-read-n-bytes s str 0 n)
222    (%epushval s (make-symbol str))))
223
224(defun %fasl-intern (s package ignore)
225  (declare (ignore ignore))
226  (multiple-value-bind (str len new-p) (%fasl-readstr s)
227    (with-package-lock (package)
228     (multiple-value-bind (symbol access internal-offset external-offset)
229                          (%find-symbol str len package)
230       (unless access
231         (unless new-p (setq str (%fasl-copystr str len)))
232         (setq symbol (%add-symbol str package internal-offset external-offset)))
233       (%epushval s symbol)))))
234
235(defun %find-pkg (name &optional (len (length name)))
236  (declare (fixnum len)
237           (optimize (speed 3) (safety 0)))
238  (with-package-list-read-lock
239      (dolist (p %all-packages%)
240        (if (dolist (pkgname (pkg.names p))
241              (when (and (= (length pkgname) len)
242                         (dotimes (i len t)
243                           ;; Aref: allow non-simple strings
244                           (unless (eq (aref name i) (schar pkgname i))
245                             (return))))
246                (return t)))
247          (return p)))))
248
249
250
251(defun pkg-arg (thing &optional deleted-ok)
252  (let* ((xthing (if (or (symbolp thing)
253                         (typep thing 'character))
254                   (string thing)
255                   thing)))
256    (let* ((typecode (typecode xthing)))
257        (declare (fixnum typecode))
258        (cond ((= typecode arch::subtag-package)
259               (if (or deleted-ok (pkg.names xthing))
260                 xthing
261                 (error "~S is a deleted package ." thing)))
262              ((or (= typecode arch::subtag-simple-base-string)
263                   (= typecode arch::subtag-simple-general-string))
264               (or (%find-pkg xthing)
265                   (%kernel-restart $xnopkg xthing)))
266              (t (report-bad-arg thing 'simple-string))))))
267
268(defun %fasl-package (s &optional ignore)
269  (declare (ignore ignore))
270  (multiple-value-bind (str len new-p) (%fasl-readstr s)
271    (let* ((p (%find-pkg str len)))
272      (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
273
274(defun %fasl-listX (s dotp)
275  (let* ((len (%fasl-read-word s)))
276    (declare (fixnum len))
277    (when (= len 0)
278      (setq len (%fasl-read-long s)))
279    (let* ((val (%epushval s (cons nil nil)))
280           (tail val))
281      (declare (type cons val tail))
282      (setf (car val) (%fasl-expr s))
283      (dotimes (i len)
284          (setf (cdr tail) (setq tail (cons (%fasl-expr s) nil))))
285      (if dotp
286        (setf (cdr tail) (%fasl-expr s)))
287      (setf (faslstate.faslval s) val))))
288
289
290
291(deffaslop $fasl-noop (s)
292  (%cant-epush s))
293
294(deffaslop $fasl-etab-alloc (s)
295  (%cant-epush s)
296  (setf (faslstate.faslevec s) (make-array (the fixnum (%fasl-read-long s)))
297        (faslstate.faslecnt s) 0))
298
299(deffaslop $fasl-arch (s)
300  (%cant-epush s)
301  (let* ((arch (%fasl-expr s)))
302    (declare (fixnum arch))
303    #+linuxppc-target
304    (unless (= arch 1) (error "Not a LinuxPPC fasl file : ~s" (faslstate.faslfname s)))
305    #+sparc-target
306    (unless (= arch 16) (error "Not a SPARC fasl file : ~s" (faslstate.faslfname s)))
307    #+darwinppc-target
308    (unless (= arch 3) (error "Not a Darwin PPC fasl file : ~s" (faslstate.faslfname s)))
309    ))
310
311(deffaslop $fasl-eref (s)
312  (let* ((idx (%fasl-read-word s)))     ; 16 bit limit ? why ?
313    (declare (fixnum idx))
314    (if (>= idx (the fixnum (faslstate.faslecnt s)))
315      (%bad-fasl s))
316    (%epushval s (svref (faslstate.faslevec s) idx))))
317
318(deffaslop $fasl-lfuncall (s)
319  (let* ((fun (%fasl-expr-preserve-epush s)))
320    ;(break "fun = ~s" fun)
321     (%epushval s (funcall fun))))
322
323(deffaslop $fasl-globals (s)
324  (setf (faslstate.faslgsymbols s) (%fasl-expr s)))
325
326(deffaslop $fasl-char (s)
327  (%epushval s (code-char (%fasl-read-byte s))))
328
329
330
331(deffaslop $fasl-fixnum (s)
332  (%epushval
333   s
334    (%compose-signed-fixnum (%fasl-read-word s) (%fasl-read-word s))))
335
336
337
338
339(deffaslop $fasl-float (s)
340  ;; A double-float is a 3-element "misc" object.
341  ;; Element 0 is always 0 and exists solely to keep elements 1 and 2
342  ;; aligned on a 64-bit boundary.
343  (let* ((df (%alloc-misc arch::double-float.element-count
344                          arch::subtag-double-float)))
345    (setf (%misc-ref df arch::double-float.value-cell)
346          (%fasl-read-long s))
347    (setf (%misc-ref df arch::double-float.val-low-cell)
348          (%fasl-read-long s))
349    (%epushval s df)))
350
351(deffaslop $fasl-str (s)
352  (let* ((n (%fasl-read-size s))
353         (str (make-string (the fixnum n) :element-type 'base-char)))
354    (%epushval s str)
355    (%fasl-read-n-bytes s str 0 n)))
356
357(deffaslop $fasl-word-fixnum (s)
358  (%epushval s (%word-to-int (%fasl-read-word s))))
359
360(deffaslop $fasl-mksym (s)
361  (%fasl-make-symbol s nil))
362
363(deffaslop $fasl-intern (s)
364  (%fasl-intern s *package* nil))
365
366(deffaslop $fasl-pkg-intern (s)
367  (let* ((pkg (%fasl-expr-preserve-epush s)))
368    #+paranoia
369    (setq pkg (pkg-arg pkg))
370    (%fasl-intern s pkg nil)))
371
372(deffaslop $fasl-pkg (s)
373  (%fasl-package s nil))
374
375(deffaslop $fasl-cons (s)
376  (let* ((cons (%epushval s (cons nil nil))))
377    (declare (type cons cons))
378    (setf (car cons) (%fasl-expr s)
379          (cdr cons) (%fasl-expr s))
380    (setf (faslstate.faslval s) cons)))
381
382(deffaslop $fasl-list (s)
383  (%fasl-listX s nil))
384
385(deffaslop $fasl-list* (s)
386  (%fasl-listX s t))
387
388(deffaslop $fasl-nil (s)
389  (%epushval s nil))
390
391
392
393(deffaslop $fasl-timm (s)
394  (rlet ((p :long))
395    (setf (%get-long p) (%fasl-read-long s))
396    (%epushval s (%get-unboxed-ptr p))))
397
398
399
400
401(deffaslop $fasl-symfn (s)
402  (%epushval s (%function (%fasl-expr-preserve-epush s))))
403   
404(deffaslop $fasl-eval (s)
405  (%epushval s (eval (%fasl-expr-preserve-epush s))))
406
407; For bootstrapping. The real version is cheap-eval in l1-readloop
408(when (not (fboundp 'eval))
409  (defun eval (form)
410    (if (and (listp form)
411             (let ((f (%car form)))
412               (and (symbolp f)
413                    (functionp (fboundp f)))))
414      (apply (%car form) (%cdr form))
415      (error "Can't eval yet: ~s" form))))
416
417
418(deffaslop $fasl-ivec (s)
419  (let* ((subtag (%fasl-read-byte s))
420         (element-count (%fasl-read-size s))
421         (size-in-bytes (subtag-bytes subtag element-count))
422         (vector (%alloc-misc element-count subtag)))
423    (declare (fixnum subtag element-count size-in-bytes))
424    (%epushval s vector)
425    (%fasl-read-n-bytes s vector 0 size-in-bytes)
426    (when (= subtag arch::subtag-code-vector)
427      (%make-code-executable vector))
428    vector))
429
430
431(deffaslop $fasl-gvec (s)
432  (let* ((subtype (%fasl-read-byte s))
433         (n (%fasl-read-size s)))
434    (declare (fixnum n subtype))
435    (if (and (= subtype arch::subtag-svar)
436             (= n arch::svar.element-count))
437      (let* ((epush (faslstate.faslepush s))
438             (ecount (faslstate.faslecnt s)))
439        (when epush
440          (%epushval s 0))
441        (let* ((sym (%fasl-expr s))
442               (ignore (%fasl-expr s))
443               (vector (ensure-svar sym)))
444          (declare (ignore ignore))
445          (when epush
446            (setf (svref (faslstate.faslevec s) ecount) vector))
447          (setf (faslstate.faslval s) vector)))
448      (let* ((vector (%alloc-misc n subtype)))
449        (%epushval s vector)
450        (dotimes (i n (setf (faslstate.faslval s) vector))
451          (setf (%svref vector i) (%fasl-expr s)))))))
452
453
454
455
456         
457(deffaslop $fasl-xchar (s)
458  (%epushval s (code-char (%fasl-read-word s))))
459   
460(deffaslop $fasl-mkxsym (s)
461  (%fasl-make-symbol s t))
462
463(deffaslop $fasl-defun (s)
464  (%cant-epush s)
465  (%defun (%fasl-expr s) (%fasl-expr s)))
466
467(deffaslop $fasl-macro (s)
468  (%cant-epush s)
469  (%macro (%fasl-expr s) (%fasl-expr s)))
470
471(deffaslop $fasl-defconstant (s)
472  (%cant-epush s)
473  (%defconstant (%fasl-expr s) (%fasl-expr s) (%fasl-expr s)))
474
475(deffaslop $fasl-defparameter (s)
476  (%cant-epush s)
477  (let* ((sym (%fasl-expr s))
478         (val (%fasl-expr s)))
479    (%defvar sym (%fasl-expr s))
480    (set sym val)))
481
482; (defvar var)
483(deffaslop $fasl-defvar (s)
484  (%cant-epush s)
485  (%defvar (%fasl-expr s)))
486
487; (defvar var initfom doc)
488(deffaslop $fasl-defvar-init (s)
489  (%cant-epush s)
490  (let* ((sym (%fasl-expr s))
491         (val (%fasl-expr s)))
492    (unless (%defvar sym (%fasl-expr s))
493      (set sym val))))
494
495(deffaslop $fasl-skip (s)
496  (%fasl-expr s)
497  (%fasl-expr s))
498
499(deffaslop $fasl-prog1 (s)
500  (let* ((val (%fasl-expr s)))
501    (%fasl-expr s)
502    (setf (faslstate.faslval s) val)))
503
504(deffaslop $fasl-xintern (s)
505  (%fasl-intern s *package* t))
506
507(deffaslop $fasl-pkg-xintern (s)
508  (let* ((pkg (%fasl-expr-preserve-epush s)))
509    #+paranoia
510    (setq pkg (pkg-arg pkg))
511    (%fasl-intern s pkg t)))
512
513(deffaslop $fasl-xpkg (s)
514  (%fasl-package s t))
515
516(deffaslop $fasl-src (s)
517  (%cant-epush s)
518  (let* ((source-file (%fasl-expr s)))
519    ; (format t "~& source-file = ~s" source-file)
520    (setq *loading-file-source-file* source-file)))
521
522#-openmcl
523(deffaslop $fasl-library-pointer (s)
524  (setf (faslstate.faslval s)
525        (pfsl-shared-library-offset s)))
526
527(defvar *modules* nil)
528
529; Bootstrapping version
530(defun provide (module-name)
531  (push module-name *modules*))
532
533(deffaslop $fasl-provide (s)
534  (provide (%fasl-expr s)))   
535
536
537;;; The loader itself
538
539(defun %simple-fasl-set-file-pos (s new)
540  (let* ((fd (faslstate.faslfd s))
541         (posoffset (fd-tell fd)))
542    (if (>= (decf posoffset new) 0)
543      (let* ((count (faslstate.bufcount s)))
544        (if (>= (decf count posoffset ) 0)
545          (progn
546            (setf (faslstate.bufcount s) posoffset)
547            (incf (%get-long (faslstate.iobuffer s)) count)
548            (return-from %simple-fasl-set-file-pos nil)))))
549    (progn
550      (setf (faslstate.bufcount s) 0)
551      (fd-lseek fd new #$SEEK_SET))))
552
553(defun %simple-fasl-get-file-pos (s)
554  (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s)))
555
556(defparameter *%fasload-verbose* t)
557
558;; the default fasl file opener sets up the fasl state and checks the header
559(defun %simple-fasl-open (string s)
560  (let* ((ok nil)
561         (fd (fd-open string #$O_RDONLY))
562         (err 0))
563    (declare (fixnum fd))
564    (if (>= fd 0)
565        (if (< (fd-lseek fd 0 #$SEEK_END) 4)
566            (setq err $xnotfasl)
567          (progn
568            (setq err 0)
569            (setf (faslstate.bufcount s) 0
570                  (faslstate.faslfd s) fd)
571            (fd-lseek fd 0 #$SEEK_SET)
572            (multiple-value-setq (ok err) (%fasl-check-header s))))
573      (setq err fd))
574    (unless (eql err 0) (setf (faslstate.faslerr s) err))
575    ok))
576
577;; once the fasl state is set up, this checks the fasl header
578;; and returns (values ok err)
579(defun %fasl-check-header (s)
580  (let* ((signature (%fasl-read-word s)))
581    (declare (fixnum signature))
582    (if (= signature $fasl-file-id)
583        (values t 0)
584      (if (= signature $fasl-file-id1)
585          (progn
586            (%fasl-set-file-pos s (%fasl-read-long s))
587            (values t 0))
588        (values nil $xnotfasl)))))
589
590(defun %simple-fasl-close (s)
591  (let* ((fd (faslstate.faslfd s)))
592    (when fd (fd-close fd))))
593
594(defun %simple-fasl-init-buffer (s)
595  (declare (ignore s))
596  nil)
597
598(defvar *fasl-api* nil)
599(setf *fasl-api* (%istruct 'faslapi
600                           #'%simple-fasl-open
601                           #'%simple-fasl-close
602                           #'%simple-fasl-init-buffer
603                           #'%simple-fasl-set-file-pos
604                           #'%simple-fasl-get-file-pos
605                           #'%simple-fasl-read-buffer
606                           #'%simple-fasl-read-byte
607                           #'%simple-fasl-read-n-bytes))
608
609(defun %fasl-open (string s)
610  (funcall (faslapi.fasl-open *fasl-api*) string s))
611(defun %fasl-close (s)
612  (funcall (faslapi.fasl-close *fasl-api*) s))
613(defun %fasl-init-buffer (s)
614  (funcall (faslapi.fasl-init-buffer *fasl-api*) s))
615(defun %fasl-set-file-pos (s new)
616  (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new))
617(defun %fasl-get-file-pos (s)
618  (funcall (faslapi.fasl-get-file-pos *fasl-api*) s))
619(defun %fasl-read-buffer (s)
620  (funcall (faslapi.fasl-read-buffer *fasl-api*) s))
621(defun %fasl-read-byte (s)
622  (funcall (faslapi.fasl-read-byte *fasl-api*) s))
623(defun %fasl-read-n-bytes (s ivector byte-offset n)
624  (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n))
625
626(defun %fasload (string &optional (table *fasl-dispatch-table*)
627                        start-faslops-function
628                        stop-faslops-function)
629  ;(dbg string)
630  (when (and *%fasload-verbose*
631             (not *load-verbose*))
632    (%string-to-stderr ";Loading ") (pdbg string))
633  (let* ((s (%istruct
634             'faslstate
635             nil
636             nil
637             nil
638             nil
639             nil
640             nil
641             nil
642             nil
643             nil
644             nil
645             nil
646             nil
647             nil
648             nil)))
649    (declare (dynamic-extent s))
650    (setf (faslstate.faslfname s) string)
651    (setf (faslstate.fasldispatch s) table)
652    (setf (faslstate.faslversion s) 0)
653    (%stack-block ((buffer (+ 4 $fasl-buf-len)))
654      (setf (faslstate.iobuffer s) buffer)
655      (%fasl-init-buffer s)
656      (let* ((parse-string (make-string 255 :element-type 'base-char)))
657        (declare (dynamic-extent parse-string))
658        (setf (faslstate.oldfaslstr s) nil
659              (faslstate.faslstr s) parse-string)
660        (unwind-protect
661          (when (%fasl-open string s)
662            (let* ((nblocks (%fasl-read-word s))
663                   (*pfsl-library-base* nil)
664                   (*pfsl-library* nil))
665              (declare (fixnum nblocks))
666              (declare (special *pfsl-library-base* *pfsl-library*))
667              (unless (= nblocks 0)
668                (let* ((pos (%fasl-get-file-pos s)))
669                  (dotimes (i nblocks)
670                    (%fasl-set-file-pos s pos)
671                    (%fasl-set-file-pos s (%fasl-read-long s))
672                    (incf pos 8)
673                    (when start-faslops-function (funcall start-faslops-function s))
674                    (let* ((version (%fasl-read-word s)))
675                      (declare (fixnum version))
676                      (if (or (> version (+ #xff00 $fasl-vers))
677                              (< version (+ #xff00 $fasl-min-vers)))
678                          (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl))
679                        (progn
680                          (setf (faslstate.faslversion s) version)
681                          (%fasl-read-word s) 
682                          (%fasl-read-word s)       ; Ignore kernel version stuff
683                          (setf (faslstate.faslevec s) nil
684                                (faslstate.faslecnt s) 0)
685                          (do* ((op (%fasl-read-byte s) (%fasl-read-byte s)))
686                               ((= op $faslend))
687                            (declare (fixnum op))
688                            (%fasl-dispatch s op))
689                          (when stop-faslops-function (funcall stop-faslops-function s))
690                          ))))))))
691          (%fasl-close s))
692        (let* ((err (faslstate.faslerr s)))
693          (if err
694              (progn
695                (when *%fasload-verbose*
696                  (let* ((herald ";!!Error loading ")
697                         (hlen (length herald))
698                         (len (length string))
699                         (msg (make-string (+ hlen len))))
700                    (declare (dynamic-extent msg))
701                    (%copy-ivector-to-ivector herald 0 msg 0 hlen)
702                    (%copy-ivector-to-ivector string 0 msg hlen len)
703                    (bug msg))
704                  (values nil err)))
705            (values t nil)))))))
706
707
708(defun %new-package-hashtable (size)
709  (%initialize-htab (cons nil (cons 0 0)) size))
710
711(defun %initialize-htab (htab size)
712  (declare (fixnum size))
713  ; Ensure that "size" is relatively prime to all secondary hash values.
714  ; If it's small enough, pick the next highest known prime out of the
715  ; "primsizes" array.  Otherwize, iterate through all all of "hprimes"
716  ; until we find something relatively prime to all of them.
717  (setq size
718        (if (> size 32749)
719          (do* ((nextsize (logior 1 size) (+ nextsize 2)))
720               ()
721            (declare (fixnum nextsize))
722            (when (dotimes (i 8 t)
723                    (unless (eql 1 (gcd nextsize (uvref #.$hprimes i)))
724                      (return)))
725              (return nextsize)))
726          (dotimes (i (the fixnum (length #.$primsizes)))
727            (let* ((psize (uvref #.$primsizes i)))
728              (declare (fixnum psize))
729              (if (>= psize size) 
730                (return psize))))))
731  (setf (htvec htab) (make-array size :initial-element nil))
732  (setf (htcount htab) 0)
733  (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3)))))
734  htab)
735
736(defun %resize-htab (htab)
737  (declare (optimize (speed 3) (safety 0)))
738  (without-interrupts
739   (let* ((old-vector (htvec htab))
740          (old-len (length old-vector)))
741     (declare (fixnum old-len)
742              (simple-vector old-vector))
743     (let* ((nsyms 0))
744       (declare (fixnum nsyms))
745       (dovector (s old-vector)
746         (and s (symbolp s) (incf nsyms)))
747       (%initialize-htab htab 
748                         (the fixnum (+ 
749                                      (the fixnum 
750                                        (+ nsyms (the fixnum (ash nsyms -2))))
751                                      2)))
752       (let* ((new-vector (htvec htab))
753              (nnew 0))
754         (declare (fixnum nnew)
755                  (simple-vector new-vector))
756         (dotimes (i old-len (setf (htcount htab) nnew))
757           (let* ((s (svref old-vector i)))
758             (when s
759               (setf (svref old-vector i) nil)       ; in case old-vector was static
760               (if (symbolp s)
761                 (let* ((pname (symbol-name s)))
762                   (setf (svref 
763                          new-vector 
764                          (nth-value 
765                           2
766                           (%get-htab-symbol 
767                            pname
768                            (length pname)
769                            htab)))
770                         s)
771                   (incf nnew))))))
772         htab)))))
773
774#+ppc-target
775(defppclapfunction %pname-hash ((str arg_y) (len arg_z))
776  (let ((nextw imm1)
777        (accum imm0)
778        (offset imm2)
779        (tag imm3))
780    (extract-subtag tag str)
781    (cmpwi cr0 len 0)
782    (li offset arch::misc-data-offset)
783    (li accum 0)
784    (beqlr- cr0)   
785    @loop8
786    (cmpwi cr1 len '1)
787    (subi len len '1)
788    (lbzx nextw str offset)
789    (addi offset offset 1)
790    (rotlwi accum accum 5)
791    (xor accum accum nextw)
792    (bne cr1 @loop8)
793    (slwi accum accum 5)
794    (srwi arg_z accum (- 5 arch::fixnumshift))
795    (blr)))
796
797#+sparc-target
798(defsparclapfunction %pname-hash ((%str %arg_y) (%len %arg_z))
799  (let ((%nextw %imm1)
800        (%accum %imm0)
801        (%offset %imm2)
802        (%tag %imm3)
803        (%accum1 %imm4))
804    (tst %len)
805    (mov arch::misc-data-offset %offset)
806    (be @done)
807     (mov 0 %accum)
808    @loop8
809    (subcc %len '1 %len)
810    (ldub (%str %offset) %nextw)
811    (add %offset 1 %offset)
812    (srl %accum 27 %accum1)
813    (sll %accum 5 %accum)
814    (or %accum %accum1 %accum)
815    (bne @loop8)
816     (xor %accum %nextw %accum)
817    (sll %accum 5 %accum)
818    @done
819    (retl)
820     (srl %accum (- 5 arch::fixnumshift) %arg_z)))
821
822       
823(defun hash-pname (str len)
824  (declare (optimize (speed 3) (safety 0)))
825  (let* ((primary (%pname-hash str len)))
826    (declare (fixnum primary))
827    (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7)))))
828
829
830   
831
832
833(defun %get-hashed-htab-symbol (str len htab primary secondary)
834  (declare (optimize (speed 3) (safety 0))
835           (fixnum primary secondary len))
836  (let* ((vec (htvec htab))
837         (vlen (length vec)))
838    (declare (fixnum vlen))
839    (do* ((idx (fast-mod primary vlen) (+ i secondary))
840          (i idx (if (>= idx vlen) (- idx vlen) idx))
841          (elt (svref vec i) (svref vec i)))
842         ((null elt) (values nil nil i))
843      (declare (fixnum i idx))
844      (when (and elt (symbolp elt))
845        (let* ((pname (symbol-name elt)))
846          (if (and 
847               (= (the fixnum (length pname)) len)
848               (dotimes (j len t)
849                 (unless (eq (aref str j) (schar pname j))
850                   (return))))
851            (return (values t (%symptr->symbol elt) i))))))))
852
853(defun %get-htab-symbol (string len htab)
854  (declare (optimize (speed 3) (safety 0)))
855  (multiple-value-bind (p s) (hash-pname string len)
856    (%get-hashed-htab-symbol string len htab p s)))
857
858(defun %find-symbol (string len package)
859  (declare (optimize (speed 3) (safety 0)))
860  (multiple-value-bind (found-p sym internal-offset)
861                       (%get-htab-symbol string len (pkg.itab package))
862    (if found-p
863      (values sym :internal internal-offset nil)
864      (multiple-value-bind (found-p sym external-offset)
865                           (%get-htab-symbol string len (pkg.etab package))
866        (if found-p
867          (values sym :external internal-offset external-offset)
868          (dolist (p (pkg.used package) (values nil nil internal-offset external-offset))
869            (multiple-value-bind (found-p sym)
870                                 (%get-htab-symbol string len (pkg.etab p))
871              (when found-p
872                (return (values sym :inherited internal-offset external-offset))))))))))
873         
874(defun %htab-add-symbol (symbol htab idx)
875  (declare (optimize (speed 3) (safety 0)))
876  (setf (svref (htvec htab) idx) (%symbol->symptr symbol))
877  (if (>= (incf (the fixnum (htcount htab)))
878          (the fixnum (htlimit htab)))
879    (%resize-htab htab))
880  symbol)
881
882(defun %set-symbol-package (symbol package-or-nil)
883  (declare (optimize (speed 3) (safety 0)))
884  (let* ((old-pp (%symbol-package-plist symbol)))
885    (if (consp old-pp)
886      (setf (car old-pp) package-or-nil)
887      (%set-symbol-package-plist symbol package-or-nil))))
888
889(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export)
890  (let* ((package-plist (%symbol-package-plist symbol))
891         (keyword-package (eq package *keyword-package*)))
892    ; Set home package
893    (if package-plist
894      (if (listp package-plist)
895        (unless (%car package-plist) (%rplaca package-plist package)))
896      (%set-symbol-package-plist symbol package))
897    (if (or force-export keyword-package)
898      (progn
899        (%htab-add-symbol symbol (pkg.etab package) external-idx)
900        (if keyword-package
901          ;(define-constant symbol symbol)
902          (progn
903            (%set-sym-global-value symbol symbol)
904            (%symbol-bits symbol 
905                          (logior (ash 1 $sym_vbit_special) 
906                                  (ash 1 $sym_vbit_const)
907                                  (the fixnum (%symbol-bits symbol)))))))
908      (%htab-add-symbol symbol (pkg.itab package) internal-idx))
909    symbol))
910
911; PNAME must be a simple string!
912(defun %add-symbol (pname package internal-idx external-idx &optional force-export)
913  (let* ((sym (make-symbol pname)))
914    (%insert-symbol sym package internal-idx external-idx force-export)))
915
916
917; The initial %toplevel-function% sets %toplevel-function% to NIL;
918; if the %fasload call fails, the lisp should exit (instead of repeating
919; the process endlessly ...
920
921
922
923(defvar %toplevel-function%
924  #'(lambda ()
925      (declare (special *xload-cold-load-functions*
926                        *xload-startup-file*))
927      (%set-tcr-toplevel-function (%current-tcr) nil)   ; should get reset by l1-boot.
928
929     (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil)))
930        (funcall f))
931     ;; Can't bind any specials until this happens
932     (%map-areas #'(lambda (o)
933                     (when (eql (typecode o) arch::subtag-svar)
934                       (cold-load-svar o)))
935                 arch::area-dynamic
936                 arch::area-dynamic)
937      (%fasload *xload-startup-file*)))
938
Note: See TracBrowser for help on using the repository browser.