source: trunk/source/lib/nfcomp.lisp @ 11183

Last change on this file since 11183 was 11183, checked in by gz, 12 years ago

Remove some obsolete bootstrapping code, some minor tweaks to indentation/organization, nothing semantically meaningful, just prep for more merging.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 76.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;; :lib:nfcomp.lisp - New fasl compiler.
20
21(eval-when (:compile-toplevel :load-toplevel :execute)
22   (require 'level-2))
23
24(require 'optimizers)
25(require 'hash)
26
27(eval-when (:compile-toplevel :execute)
28
29(require 'backquote)
30(require 'defstruct-macros)
31
32(defmacro short-fixnum-p (fixnum)
33  `(and (fixnump ,fixnum) (< (integer-length ,fixnum) 16)))
34
35(require "FASLENV" "ccl:xdump;faslenv")
36
37#+ppc32-target
38(require "PPC32-ARCH")
39#+ppc64-target
40(require "PPC64-ARCH")
41#+x8632-target
42(require "X8632-ARCH")
43#+x8664-target
44(require "X8664-ARCH")
45) ;eval-when (:compile-toplevel :execute)
46
47;File compiler options.  Not all of these need to be exported/documented, but
48;they should be in the product just in case we need them for patches....
49(defvar *fasl-save-local-symbols* t)
50(defvar *fasl-deferred-warnings* nil)
51(defvar *fasl-non-style-warnings-signalled-p* nil)
52(defvar *fasl-warnings-signalled-p* nil)
53(defvar *compile-verbose* nil ; Might wind up getting called *compile-FILE-verbose*
54  "The default for the :VERBOSE argument to COMPILE-FILE.")
55(defvar *fasl-save-doc-strings*  t)
56(defvar *fasl-save-definitions* nil)
57(defvar *compile-file-pathname* nil
58  "The defaulted pathname of the file currently being compiled, or NIL if not
59  compiling.") ; pathname of src arg to COMPILE-FILE
60(defvar *compile-file-truename* nil
61  "The TRUENAME of the file currently being compiled, or NIL if not
62  compiling.") ; truename ...
63(defvar *fasl-target* (backend-name *host-backend*))
64(defvar *fasl-backend* *host-backend*)
65(defvar *fasl-host-big-endian*
66  (arch::target-big-endian (backend-target-arch *host-backend*)))
67(defvar *fasl-target-big-endian* *fasl-host-big-endian*)
68(defvar *fcomp-external-format* :default)
69
70(defvar *fasl-break-on-program-errors* #+ccl-0711 nil #-ccl-0711 :defer
71  "Controls what happens when the compiler detects PROGRAM-ERROR's during file compilation.
72
73  If T, the compiler signals an error immediately when it detects the program-error.
74
75  If :DEFER, program errors are reported as compiler warnings, and in addition, an error
76    is signalled at the end of file compilation.  This allows all warnings for the file
77    to be reported, but prevents the creation of a fasl file.
78
79  If NIL, program errors are treated the same as any other error condition detected by
80   the compiler, i.e. they are reported as compiler warnings and do not cause any
81   error to be signalled at compile time.")
82 
83
84(defvar *compile-print* nil ; Might wind up getting called *compile-FILE-print*
85  "The default for the :PRINT argument to COMPILE-FILE.")
86
87;Note: errors need to rebind this to NIL if they do any reading without
88; unwinding the stack!
89(declaim (special *compiling-file*)) ; defined in l1-init.
90
91(defvar *fasl-source-file* nil "Name of file currently being read from.
92Will differ from *compiling-file* during an INCLUDE")
93
94(defparameter *fasl-package-qualified-symbols* '(*loading-file-source-file* set-package %define-package)
95  "These symbols are always fasdumped with full package qualification.")
96
97(defun setup-target-features (backend features)
98  (if (eq backend *host-backend*)
99    features
100    (let* ((new nil)
101           (nope (backend-target-specific-features *host-backend*)))
102      (dolist (f features)
103        (unless (memq f nope) (pushnew f new)))
104      (dolist (f (backend-target-specific-features backend)
105               (progn (pushnew :cross-compiling new) new))
106        (pushnew f new)))))
107
108(defun compile-file-pathname (pathname &rest ignore &key output-file &allow-other-keys)
109  "Return a pathname describing what file COMPILE-FILE would write to given
110   these arguments."
111  (declare (ignore ignore))
112  (setq pathname (merge-pathnames pathname))
113  (merge-pathnames (if output-file
114                     (merge-pathnames output-file *.fasl-pathname*)
115                     *.fasl-pathname*) 
116                   pathname))
117
118(defun compile-file (src &key output-file
119                         (verbose *compile-verbose*)
120                         (print *compile-print*)
121                         load
122                         features
123                         (target *fasl-target* target-p)
124                         (save-local-symbols *fasl-save-local-symbols*)
125                         (save-doc-strings *fasl-save-doc-strings*)
126                         (save-definitions *fasl-save-definitions*)
127                         (break-on-program-errors *fasl-break-on-program-errors*)
128                         (external-format :default)
129                         force)
130  "Compile INPUT-FILE, producing a corresponding fasl file and returning
131   its filename."
132  (let* ((backend *target-backend*))
133    (when (and target-p (not (setq backend (find-backend target))))
134      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
135      (setq target *fasl-target*  backend *target-backend*))
136    (loop
137        (restart-case
138         (return (%compile-file src output-file verbose print load features
139                                save-local-symbols save-doc-strings save-definitions
140                                break-on-program-errors
141                                force backend external-format))
142         (retry-compile-file ()
143                             :report (lambda (stream) (format stream "Retry compiling ~s" src))
144                             nil)
145         (skip-compile-file ()
146                            :report (lambda (stream) (format stream "Skip compiling ~s" src))
147                            (return))))))
148
149(defvar *fasl-compile-time-env* nil)
150
151(defun %compile-file (src output-file verbose print load features
152                          save-local-symbols save-doc-strings save-definitions
153                          break-on-program-errors
154                          force target-backend external-format
155                          &aux orig-src)
156
157  (setq orig-src (merge-pathnames src))
158  (let* ((output-default-type (backend-target-fasl-pathname target-backend)))
159    (setq src (fcomp-find-file orig-src))
160    (let* ((newtype (pathname-type src)))
161      (when (and newtype (not (pathname-type orig-src)))
162        (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil)))))
163    (setq output-file (merge-pathnames
164                       (if output-file ; full-pathname in case output-file is relative
165                         (full-pathname (merge-pathnames output-file output-default-type) :no-error nil) 
166                         output-default-type)
167                       orig-src))
168    ;; This should not be necessary, but it is.
169    (setq output-file (namestring output-file))
170    (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time
171      (setq orig-src (back-translate-pathname orig-src '("home" "ccl"))))
172    (let* ((*fasl-non-style-warnings-signalled-p* nil)
173           (*fasl-warnings-signalled-p* nil))
174      (when (and (not force)
175                 (probe-file output-file)
176                 (not (fasl-file-p output-file)))
177        (unless (y-or-n-p
178                 (format nil
179                         "Compile destination ~S is not ~A file!  Overwrite it?"
180                         output-file (pathname-type
181                                      (backend-target-fasl-pathname
182                                       *target-backend*))))
183        (return-from %compile-file nil)))
184      (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*)))
185             (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
186             (*fasl-save-local-symbols* save-local-symbols)
187             (*fasl-save-doc-strings* save-doc-strings)
188             (*fasl-save-definitions* save-definitions)
189             (*fasl-break-on-program-errors* break-on-program-errors)
190             (*fcomp-warnings-header* nil)
191             (*compile-file-pathname* orig-src)
192             (*compile-file-truename* (truename src))
193             (*package* *package*)
194             (*readtable* *readtable*)
195             (*compile-print* print)
196             (*compile-verbose* verbose)
197             (*fasl-target* (backend-name target-backend))
198             (*fasl-backend* target-backend)
199             (*fasl-target-big-endian* (arch::target-big-endian
200                                        (backend-target-arch target-backend)))
201             (*target-ftd* (backend-target-foreign-type-data target-backend))
202             (defenv (new-definition-environment))
203             (lexenv (new-lexical-environment defenv))
204             (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment)))
205             (*fcomp-external-format* external-format))
206        (let ((forms nil))
207          (let* ((*outstanding-deferred-warnings* (%defer-warnings nil)))
208            (rplacd (defenv.type defenv) *outstanding-deferred-warnings*)
209            (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*))
210
211            (setq forms (fcomp-file src orig-src lexenv))
212
213            (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) 
214                  (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*)))
215            (when *compile-verbose* (fresh-line))
216            (multiple-value-bind (any harsh) (report-deferred-warnings)
217              (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any)
218                    *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very
219                                                              (or *fasl-non-style-warnings-signalled-p* harsh)))))
220          (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very))
221            (cerror "create the output file despite the errors"
222                    "Serious errors encountered during compilation of ~s"
223                    src))
224          (fasl-scan-forms-and-dump-file forms output-file lexenv)))
225      (when load (load output-file :verbose (or verbose *load-verbose*)))
226      (values (truename (pathname output-file)) 
227              *fasl-warnings-signalled-p* 
228              (and *fasl-non-style-warnings-signalled-p* t)))))
229
230(defvar *fcomp-locked-hash-tables*)
231(defvar *fcomp-load-forms-environment* nil)
232
233; This is separated out so that dump-forms-to-file can use it
234(defun fasl-scan-forms-and-dump-file (forms output-file &optional env)
235  (let ((*fcomp-locked-hash-tables* nil)
236        (*fcomp-load-forms-environment* env))
237    (unwind-protect
238      (multiple-value-bind (hash gnames goffsets) (fasl-scan forms)
239        (fasl-dump-file gnames goffsets forms hash output-file))
240      (fasl-unlock-hash-tables))))
241
242#-bccl
243(defun nfcomp (src &optional dest &rest keys)
244  (when (keywordp dest) (setq keys (cons dest keys) dest nil))
245  (apply #'compile-file src :output-file dest keys))
246
247#-bccl
248(%fhave 'fcomp #'nfcomp)
249
250(defparameter *default-file-compilation-policy* (new-compiler-policy))
251
252(defun current-file-compiler-policy ()
253  *default-file-compilation-policy*)
254
255(defun set-current-file-compiler-policy (&optional new-policy)
256  (setq *default-file-compilation-policy* 
257        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))
258
259(defparameter *compile-time-evaluation-policy*
260  (new-compiler-policy :force-boundp-checks t))
261
262(defun %compile-time-eval (form env)
263  (declare (ignore env))
264  (let* ((*target-backend* *host-backend*))
265    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
266    ;; signaled during (eval-when (:compile-toplevel) processing; this
267    ;; in turn is supposed to satisfy a pedantic interpretation of the
268    ;; spec's requirement that COMPILE-FILE's second and third return
269    ;; values reflect (all) conditions "detected by the compiler."
270    ;; (It's kind of sad that CL language design is influenced so
271    ;; strongly by the views of pedants these days.)
272    (handler-bind ((warning (lambda (c)
273                              (setq *fasl-warnings-signalled-p* t)
274                              (unless (typep c 'style-warning)
275                                (setq *fasl-non-style-warnings-signalled-p* t))
276                              (signal c))))
277      (funcall (compile-named-function
278                `(lambda () ,form)
279                :env *fasl-compile-time-env*
280                :policy *compile-time-evaluation-policy*)))))
281
282
283;;; No methods by default, not even for structures.  This really sux.
284(defgeneric make-load-form (object &optional environment))
285
286;;; Well, no usable methods by default.  How this is better than
287;;; getting a NO-APPLICABLE-METHOD error frankly escapes me,
288(defun no-make-load-form-for (object)
289  (error "No ~S method is defined for ~s" 'make-load-form object))
290
291(defmethod make-load-form ((s standard-object) &optional environment)
292  (declare (ignore environment))
293  (no-make-load-form-for s))
294
295(defmethod make-load-form ((s structure-object) &optional environment)
296  (declare (ignore environment))
297  (no-make-load-form-for s))
298
299(defmethod make-load-form ((c condition) &optional environment)
300  (declare (ignore environment))
301  (no-make-load-form-for c))
302
303(defmethod make-load-form ((c class) &optional environment)
304  (let* ((name (class-name c))
305         (found (if name (find-class name nil environment))))
306    (if (eq found c)
307      `(find-class ',name)
308      (error "Class ~s does not have a proper name." c))))
309
310
311;;;;          FCOMP-FILE - read & compile file
312;;;;          Produces a list of (opcode . args) to run on loading, intermixed
313;;;;          with read packages.
314
315(defparameter *fasl-eof-forms* nil)
316
317(defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL"))
318(%macro-have cfasl-load-time-eval-sym
319    #'(lambda (call env) (declare (ignore env)) (list 'eval (list 'quote call))))
320;Make it a constant so compiler will barf if try to bind it, e.g. (LET #,foo ...)
321(define-constant cfasl-load-time-eval-sym cfasl-load-time-eval-sym)
322
323
324(defparameter *reading-for-cfasl* nil "Used by the reader for #,")
325
326
327
328(declaim (special *nx-compile-time-types*
329;The following are the global proclaimed values.  Since compile-file binds
330;them, this means you can't ever globally proclaim these things from within a
331;file compile (e.g. from within eval-when compile, or loading a file) - the
332;proclamations get lost when compile-file exits.  This is sort of intentional
333;(or at least the set of things which fall in this category as opposed to
334;having a separate compile-time variable is sort of intentional).
335                    *nx-proclaimed-inline*    ; inline and notinline
336                    *nx-proclaimed-ignore*    ; ignore and unignore
337                    *nx-known-declarations*   ; declaration
338                    *nx-speed*                ; optimize speed
339                    *nx-space*                ; optimize space
340                    *nx-safety*               ; optimize safety
341                    *nx-cspeed*))             ; optimize compiler-speed
342
343(defvar *fcomp-load-time*)
344(defvar *fcomp-inside-eval-always* nil)
345(defvar *fcomp-eval-always-functions* nil)   ; used by the LISP package
346(defvar *fcomp-output-list*)
347(defvar *fcomp-toplevel-forms*)
348(defvar *fcomp-warnings-header*)
349(defvar *fcomp-stream-position* nil)
350(defvar *fcomp-previous-position* nil)
351(defvar *fcomp-indentation*)
352(defvar *fcomp-print-handler-plist* nil)
353(defvar *fcomp-last-compile-print*
354  '(INCLUDE (NIL . T)
355    DEFSTRUCT ("Defstruct" . T) 
356    DEFCONSTANT "Defconstant" 
357    DEFSETF "Defsetf" 
358    DEFTYPE "Deftype" 
359    DEFCLASS "Defclass" 
360    DEFGENERIC "Defgeneric"
361    DEFMETHOD "Defmethod"
362    DEFMACRO "Defmacro" 
363    DEFPARAMETER "Defparameter" 
364    DEFVAR "Defvar" 
365    DEFUN ""))
366
367(setf (getf *fcomp-print-handler-plist* 'defun) ""
368      (getf *fcomp-print-handler-plist* 'defvar) "Defvar"
369      (getf *fcomp-print-handler-plist* 'defparameter) "Defparameter"
370      (getf *fcomp-print-handler-plist* 'defmacro) "Defmacro"
371      (getf *fcomp-print-handler-plist* 'defmethod) "Defmethod"  ; really want more than name (use the function option)
372      (getf *fcomp-print-handler-plist* 'defgeneric) "Defgeneric"
373      (getf *fcomp-print-handler-plist* 'defclass) "Defclass"
374      (getf *fcomp-print-handler-plist* 'deftype) "Deftype"
375      (getf *fcomp-print-handler-plist* 'defsetf) "Defsetf"
376      (getf *fcomp-print-handler-plist* 'defconstant) "Defconstant"
377      (getf *fcomp-print-handler-plist* 'defstruct) '("Defstruct" . t)
378      (getf *fcomp-print-handler-plist* 'include) '(nil . t))
379
380
381(defun fcomp-file (filename orig-file env)  ; orig-file is back-translated
382  (let* ((*package* *package*)
383         (*compiling-file* filename)
384         (*nx-compile-time-types* *nx-compile-time-types*)
385         (*nx-proclaimed-inline* *nx-proclaimed-inline*)
386         (*nx-known-declarations* *nx-known-declarations*)
387         (*nx-proclaimed-ignore* *nx-proclaimed-ignore*)
388         (*nx-speed* *nx-speed*)
389         (*nx-space* *nx-space*)
390         (*nx-debug* *nx-debug*)
391         (*nx-safety* *nx-safety*)
392         (*nx-cspeed* *nx-cspeed*)
393         (*fcomp-load-time* t)
394         (*fcomp-output-list* nil)
395         (*fcomp-indentation* 0)
396         (*fcomp-last-compile-print* (cons nil (cons nil nil))))
397    (push (list $fasl-platform (backend-target-platform *fasl-backend*)) *fcomp-output-list*)
398    (fcomp-read-loop filename orig-file env :not-compile-time)
399    (nreverse *fcomp-output-list*)))
400
401(defun fcomp-find-file (file &aux path)
402  (unless (or (setq path (probe-file file))
403              (setq path (probe-file (merge-pathnames file *.lisp-pathname*))))
404    (error 'file-error :pathname file :error-type "File ~S not found"))
405  (namestring path))
406
407;;; orig-file is back-translated when from fcomp-file
408;;; when from fcomp-include it's included filename merged with *compiling-file*
409;;; which is not back translated
410(defun fcomp-read-loop (filename orig-file env processing-mode)
411  (when *compile-verbose*
412    (format t "~&;~A ~S..."
413            (if (eq filename *compiling-file*) "Compiling" " Including")
414            filename))
415  (with-open-file (stream filename
416                          :element-type 'base-char
417                          :external-format *fcomp-external-format*)
418    (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))           
419           (*fasl-source-file* filename)
420           (*fcomp-toplevel-forms* nil)
421           (*fasl-eof-forms* nil)
422           (*loading-file-source-file* (namestring orig-file)) ; why orig-file???
423           (eofval (cons nil nil))
424           (read-package nil)
425           form)
426      (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*))
427      ;;This should really be something like `(set-loading-source
428      ;;,filename) but then couldn't compile level-1 with this...  ->
429      ;;In any case, change this to be a fasl opcode, so don't make an
430      ;;lfun just to do this...  There are other reasons - more
431      ;;compelling ones than "fear of tiny lfuns" - for making this a
432      ;;fasl opcode.
433      (fcomp-output-form $fasl-src env *loading-file-source-file*)
434      (let* ((*fcomp-previous-position* nil))
435        (loop
436          (let* ((*fcomp-stream-position* (file-position stream))
437                 (*nx-warnings* nil))
438            (unless (eq read-package *package*)
439              (fcomp-compile-toplevel-forms env)
440              (setq read-package *package*))
441            (let ((*reading-for-cfasl*
442                   (and *fcomp-load-time* cfasl-load-time-eval-sym)))
443              (declare (special *reading-for-cfasl*))
444              (let ((pos (file-position stream)))
445                (handler-bind
446                    ((error #'(lambda (c) ; we should distinguish read errors from others?
447                                (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
448                                (signal c))))
449                  (setq form (read stream nil eofval)))))
450            (when (eq eofval form) (return))
451            (fcomp-form form env processing-mode)
452            (fcomp-signal-or-defer-warnings *nx-warnings* env)
453            (setq *fcomp-previous-position* *fcomp-stream-position*))))
454      (while (setq form *fasl-eof-forms*)
455        (setq *fasl-eof-forms* nil)
456        (fcomp-form-list form env processing-mode))
457      (when old-file
458        (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
459      (fcomp-compile-toplevel-forms env))))
460
461
462
463(defun fcomp-form (form env processing-mode
464                        &aux print-stuff 
465                        (load-time (and processing-mode (neq processing-mode :compile-time)))
466                        (compile-time-too (or (eq processing-mode :compile-time) 
467                                              (eq processing-mode :compile-time-too))))
468  (let* ((*fcomp-indentation* *fcomp-indentation*)
469         (*compile-print* *compile-print*))
470    (when *compile-print*
471      (cond ((and (consp form) (setq print-stuff (getf *fcomp-print-handler-plist* (car form))))
472             (rplaca (rplacd (cdr *fcomp-last-compile-print*) nil) nil)
473             (rplaca *fcomp-last-compile-print* nil)         
474             (let ((print-recurse nil))
475               (when (consp print-stuff)
476                 (setq print-recurse (cdr print-stuff) print-stuff (car print-stuff)))
477               (cond ((stringp print-stuff)
478                      (if (equal print-stuff "")
479                        (format t "~&~vT~S~%" *fcomp-indentation* (second form))
480                        (format t "~&~vT~S [~A]~%" *fcomp-indentation* (second form) print-stuff)))
481                     ((not (null print-stuff))
482                      (format t "~&~vT" *fcomp-indentation*)
483                      (funcall print-stuff form *standard-output*)
484                      (terpri *standard-output*)))
485               (if print-recurse
486                 (setq *fcomp-indentation* (+ *fcomp-indentation* 4))
487                 (setq *compile-print* nil))))
488            (t (unless (and (eq load-time (car *fcomp-last-compile-print*))
489                            (eq compile-time-too (cadr *fcomp-last-compile-print*))
490                            (eq *fcomp-indentation* (cddr *fcomp-last-compile-print*)))
491                 (rplaca *fcomp-last-compile-print* load-time)
492                 (rplaca (rplacd (cdr *fcomp-last-compile-print*) compile-time-too) *fcomp-indentation*)
493                 (format t "~&~vTToplevel Forms...~A~%"
494                         *fcomp-indentation*
495                         (if load-time
496                           (if compile-time-too
497                             "  (Compiletime, Loadtime)"
498                             "")
499                           (if compile-time-too
500                             "  (Compiletime)"
501                             "")))))))
502    (fcomp-form-1 form env processing-mode)))
503           
504(defun fcomp-form-1 (form env processing-mode &aux sym body)
505  (if (consp form) (setq sym (%car form) body (%cdr form)))
506  (case sym
507    (progn (fcomp-form-list body env processing-mode))
508    (eval-when (fcomp-eval-when body env processing-mode))
509    (compiler-let (fcomp-compiler-let body env processing-mode))
510    (locally (fcomp-locally body env processing-mode))
511    (macrolet (fcomp-macrolet body env processing-mode))
512    (symbol-macrolet (fcomp-symbol-macrolet body env processing-mode))
513    ((%include include) (fcomp-include form env processing-mode))
514    (t
515     ;;Need to macroexpand to see if get more progn's/eval-when's and so should
516     ;;stay at toplevel.  But don't expand if either the evaluator or the
517     ;;compiler might not - better safe than sorry...
518     ;; Good advice, but the hard part is knowing which is which.
519     (cond 
520       ((and (non-nil-symbol-p sym)
521             (macro-function sym env)           
522             (not (compiler-macro-function sym env))
523             (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
524             (multiple-value-bind (new win) (macroexpand-1 form env)
525               (if win (setq form new))
526               win))
527        (fcomp-form form env processing-mode))
528       ((and (not *fcomp-inside-eval-always*)
529             (memq sym *fcomp-eval-always-functions*))
530        (let* ((*fcomp-inside-eval-always* t))
531          (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-toplevel) ,form) env processing-mode)))
532       (t
533        (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
534          (%compile-time-eval form env))
535        (when (and processing-mode (neq processing-mode :compile-time))
536          (case sym
537            ((%defconstant) (fcomp-load-%defconstant form env))
538            ((%defparameter) (fcomp-load-%defparameter form env))
539            ((%defvar %defvar-init) (fcomp-load-defvar form env))
540            ((%defun) (fcomp-load-%defun form env))
541            ((set-package %define-package)
542             (fcomp-random-toplevel-form form env)
543             (fcomp-compile-toplevel-forms env))
544            ((%macro) (fcomp-load-%macro form env))
545            ;; ((%deftype) (fcomp-load-%deftype form))
546            ;; ((define-setf-method) (fcomp-load-define-setf-method form))
547            (t (fcomp-random-toplevel-form form env)))))))))
548
549(defun fcomp-form-list (forms env processing-mode)
550  (dolist (form forms) (fcomp-form form env processing-mode)))
551
552(defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
553  (fcomp-compile-toplevel-forms env)
554  (dolist (pair (pop form))
555    (push (nx-pair-name pair) vars)
556    (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
557  (progv (nreverse vars) (nreverse varinits)
558                 (fcomp-form-list form env processing-mode)
559                 (fcomp-compile-toplevel-forms env)))
560
561(defun fcomp-locally (body env processing-mode)
562  (fcomp-compile-toplevel-forms env)
563  (multiple-value-bind (body decls) (parse-body body env)
564    (let* ((env (augment-environment env :declare (decl-specs-from-declarations decls))))
565      (fcomp-form-list body env processing-mode)
566      (fcomp-compile-toplevel-forms env))))
567
568(defun fcomp-macrolet (body env processing-mode)
569  (fcomp-compile-toplevel-forms env)
570  (let ((outer-env (augment-environment env 
571                                        :macro
572                                        (mapcar #'(lambda (m)
573                                                    (destructuring-bind (name arglist &body body) m
574                                                      (list name (enclose (parse-macro name arglist body env)
575                                                                          env))))
576                                                (car body)))))
577    (multiple-value-bind (body decls) (parse-body (cdr body) outer-env)
578      (let* ((env (augment-environment 
579                   outer-env
580                   :declare (decl-specs-from-declarations decls))))
581        (fcomp-form-list body env processing-mode)
582        (fcomp-compile-toplevel-forms env)))))
583
584(defun fcomp-symbol-macrolet (body env processing-mode)
585  (fcomp-compile-toplevel-forms env)
586  (let* ((outer-env (augment-environment env :symbol-macro (car body))))
587    (multiple-value-bind (body decls) (parse-body (cdr body) env)
588      (let* ((env (augment-environment outer-env 
589                                       :declare (decl-specs-from-declarations decls))))
590        (fcomp-form-list body env processing-mode)
591        (fcomp-compile-toplevel-forms env)))))
592                                                               
593(defun fcomp-eval-when (form env processing-mode &aux (eval-times (pop form)))
594  (let* ((compile-time-too  (eq processing-mode :compile-time-too))
595         (compile-time-only (eq processing-mode :compile-time))
596         (at-compile-time nil)
597         (at-load-time nil)
598         (at-eval-time nil))
599    (dolist (when eval-times)
600      (if (or (eq when 'compile) (eq when :compile-toplevel))
601        (setq at-compile-time t)
602        (if (or (eq when 'eval) (eq when :execute))
603          (setq at-eval-time t)
604          (if (or (eq when 'load) (eq when :load-toplevel))
605            (setq at-load-time t)
606            (warn "Unknown EVAL-WHEN time ~s in ~S while compiling ~S."
607                  when eval-times *fasl-source-file*)))))
608    (fcomp-compile-toplevel-forms env)        ; always flush the suckers
609    (cond (compile-time-only
610           (if at-eval-time (fcomp-form-list form env :compile-time)))
611          (at-load-time
612           (fcomp-form-list form env (if (or at-compile-time (and at-eval-time compile-time-too))
613                                       :compile-time-too
614                                       :not-compile-time)))
615          ((or at-compile-time (and at-eval-time compile-time-too))
616           (fcomp-form-list form env :compile-time))))
617  (fcomp-compile-toplevel-forms env))
618
619(defun fcomp-include (form env processing-mode &aux file)
620  (fcomp-compile-toplevel-forms env)
621  (verify-arg-count form 1 1)
622  (setq file (nx-transform (%cadr form) env))
623  (unless (constantp file) (report-bad-arg file '(or string pathname)))
624  (let ((actual (merge-pathnames (eval-constant file)
625                                 (directory-namestring *compiling-file*))))
626    (when *compile-print* (format t "~&~vTIncluding file ~A~%" *fcomp-indentation* actual))
627    (let ((*fcomp-indentation* (+ 4 *fcomp-indentation*))
628          (*package* *package*))
629      (fcomp-read-loop (fcomp-find-file actual) actual env processing-mode)
630      (fcomp-output-form $fasl-src env *loading-file-source-file*))
631    (when *compile-print* (format t "~&~vTFinished included file ~A~%" *fcomp-indentation* actual))))
632
633(defun define-compile-time-constant (symbol initform env)
634  (note-variable-info symbol t env)
635  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
636        (definition-env (definition-environment env)))
637    (when (or compile-time-defenv definition-env)
638      (multiple-value-bind (value error) 
639                           (ignore-errors (values (%compile-time-eval initform env) nil))
640        (when error
641          (warn "Compile-time evaluation of DEFCONSTANT initial value form for ~S while ~
642                 compiling ~S signalled the error: ~&~A" symbol *fasl-source-file* error))
643        (let ((cell (cons symbol (if error (%unbound-marker-8) value))))
644          (when definition-env
645            (push cell (defenv.constants definition-env)))
646          (when compile-time-defenv
647            (push cell (defenv.constants compile-time-defenv))))))
648    symbol))
649
650(defun fcomp-load-%defconstant (form env)
651  (destructuring-bind (sym valform &optional doc) (cdr form)
652    (unless *fasl-save-doc-strings*
653      (setq doc nil))
654    (if (quoted-form-p sym)
655      (setq sym (%cadr sym)))
656    (if (and (typep sym 'symbol) (or  (quoted-form-p valform) (self-evaluating-p valform)))
657      (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc))
658      (fcomp-random-toplevel-form form env))))
659
660(defun fcomp-load-%defparameter (form env)
661  (destructuring-bind (sym valform &optional doc) (cdr form)
662    (unless *fasl-save-doc-strings*
663      (setq doc nil))
664    (if (quoted-form-p sym)
665      (setq sym (%cadr sym)))
666    (let* ((fn (fcomp-function-arg valform env)))
667      (if (and (typep sym 'symbol) (or fn (constantp valform)))
668        (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc))
669        (fcomp-random-toplevel-form form env)))))
670
671; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here.
672; Only try to dump this as a special fasl operator if the initform is missing
673;  or is "harmless" to evaluate whether needed or not (constant or function.)
674; Hairier initforms could be handled by another fasl operator that takes a thunk
675; and conditionally calls it.
676(defun fcomp-load-defvar (form env)
677  (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form)
678    (unless *fasl-save-doc-strings*
679      (setq doc nil))
680    (if (quoted-form-p sym)             ; %defvar quotes its arg, %defvar-init doesn't.
681      (setq sym (%cadr sym)))
682    (let* ((sym-p (typep sym 'symbol)))
683      (if (and sym-p (not val-p))
684        (fcomp-output-form $fasl-defvar env sym)
685        (let* ((fn (if sym-p (fcomp-function-arg valform env))))
686          (if (and sym-p (or fn (constantp valform)))
687            (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc))
688            (fcomp-random-toplevel-form (macroexpand-1 form env) env)))))))
689     
690
691
692(defun define-compile-time-macro (name lambda-expression env)
693  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
694        (definition-env (definition-environment env)))
695    (when (or definition-env compile-time-defenv)
696      (let ((cell (list* name 
697                         'macro 
698                         (compile-named-function lambda-expression :name name :env env))))
699        (when compile-time-defenv
700          (push cell (defenv.functions compile-time-defenv)))
701        (when definition-env
702          (push cell (defenv.functions definition-env))))
703      (record-function-info name (%cons-def-info 'defmacro) env))
704    name))
705
706(defun define-compile-time-symbol-macro (name expansion env)
707  (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*))
708        (definition-env (definition-environment env)))
709    (when (or definition-env compile-time-defenv)
710      (let ((cell (cons name expansion)))
711        (when compile-time-defenv
712          (push cell (defenv.functions compile-time-defenv)))
713        (when definition-env
714          (push cell (defenv.functions definition-env)))))
715    name))
716
717
718(defun fcomp-proclaim-type (type syms)
719  (dolist (sym syms)
720    (if (symbolp sym)
721    (push (cons sym type) *nx-compile-time-types*)
722      (warn "~S isn't a symbol in ~S type declaration while compiling ~S."
723            sym type *fasl-source-file*))))
724
725(defun compile-time-proclamation (specs env &aux  sym (defenv (definition-environment env)))
726  (when defenv
727    (dolist (spec specs)
728      (setq sym (pop spec))
729      (case sym
730        (type
731         (fcomp-proclaim-type (car spec) (cdr spec)))
732        (special
733         (dolist (sym spec)
734           (push (cons (require-type sym 'symbol) nil) (defenv.specials defenv))))
735        (notspecial
736         (let ((specials (defenv.specials defenv)))
737           (dolist (sym spec (setf (defenv.specials defenv) specials))
738             (let ((pair (assq sym specials)))
739               (when pair (setq specials (nremove pair specials)))))))
740        (optimize
741         (%proclaim-optimize spec))
742        (inline
743         (dolist (sym spec)
744           (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv))))
745        (notinline
746         (dolist (sym spec)
747           (unless (compiler-special-form-p sym)
748             (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv)))))
749        (declaration
750         (dolist (sym spec)
751           (pushnew (require-type sym 'symbol) *nx-known-declarations*)))
752        (ignore
753         (dolist (sym spec)
754           (push (cons (require-type sym 'symbol) t) *nx-proclaimed-ignore*)))
755        (unignore
756         (dolist (sym spec)
757           (push (cons (require-type sym 'symbol) nil) *nx-proclaimed-ignore*)))
758        (ftype 
759         (let ((ftype (car spec))
760               (fnames (cdr spec)))
761           ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done
762           (if (and (consp ftype)
763                    (consp fnames)
764                    (eq (%car ftype) 'function))
765             (dolist (fname fnames)
766               (note-function-info fname nil env)))
767           (dolist (fname fnames)
768             (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))))
769        (otherwise
770         (if (memq (if (consp sym) (%car sym) sym) *cl-types*)
771           (fcomp-proclaim-type sym spec)       ; A post-cltl2 cleanup issue changes this
772           nil)                         ; ---- probably ought to complain
773         )))))
774
775(defun fcomp-load-%defun (form env)
776  (destructuring-bind (fn &optional doc) (cdr form)
777    (unless *fasl-save-doc-strings*
778      (if (consp doc)
779        (if (and (eq (car doc) 'quote) (consp (cadr doc)))
780          (setf (car (cadr doc)) nil))
781        (setq doc nil)))
782    (when (and (consp fn) (eq (%car fn) 'nfunction))
783      (note-function-info (cadr fn) (caddr fn) env))
784    (if (and (constantp doc)
785             (setq fn (fcomp-function-arg fn env)))
786      (progn
787        (setq doc (eval-constant doc))
788        (fcomp-output-form $fasl-defun env fn doc))
789      (fcomp-random-toplevel-form form env))))
790
791(defun fcomp-load-%macro (form env &aux fn doc)
792  (verify-arg-count form 1 2)
793  (if (and (constantp (setq doc (caddr form)))
794           (setq fn (fcomp-function-arg (cadr form) env)))
795    (progn
796      (setq doc (eval-constant doc))
797      (fcomp-output-form $fasl-macro env fn doc))
798    (fcomp-random-toplevel-form form env)))
799
800(defun define-compile-time-structure (sd refnames predicate env)
801  (let ((defenv (definition-environment env)))
802    (when defenv
803      (when (non-nil-symbolp (sd-name sd))
804        (push (make-instance 'compile-time-class :name (sd-name sd))
805              (defenv.classes defenv)))
806      (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv)))
807      (let* ((structrefs (defenv.structrefs defenv)))
808        (when (and (null (sd-type sd))
809                   predicate)
810          (setq structrefs (alist-adjoin predicate (sd-name sd) structrefs)))
811        (dolist (slot (sd-slots sd))
812          (unless (fixnump (ssd-name slot))
813            (setq structrefs
814                (alist-adjoin (if refnames (pop refnames) (ssd-name slot))
815                              (ssd-type-and-refinfo slot)
816                              structrefs))))
817        (setf (defenv.structrefs defenv) structrefs)))))
818
819
820
821(defun fcomp-transform (form env)
822  (nx-transform form env))
823
824(defun fcomp-random-toplevel-form (form env)
825  (unless (constantp form)
826    (unless (or (atom form)
827                (compiler-special-form-p (%car form)))
828      ;;Pre-compile any lfun args.  This is an efficiency hack, since compiler
829      ;;reentering itself for inner lambdas tends to be more expensive than
830      ;;top-level compiles.
831      ;;This assumes the form has been macroexpanded, or at least none of the
832      ;;non-evaluated macro arguments could look like functions.
833      (let (lfun (args (%cdr form)))
834        (while args
835          (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
836            (when (or (setq lfun (fcomp-function-arg arg env))
837                      win)
838              (when lfun (setq arg `',lfun))
839              (labels ((subst-l (new ptr list)
840                         (if (eq ptr list) (cons new (cdr list))
841                           (cons (car list) (subst-l new ptr (%cdr list))))))
842                (setq form (subst-l arg args form))))
843            (setq args (%cdr args))))))
844    (push form *fcomp-toplevel-forms*)))
845
846(defun fcomp-function-arg (expr env)
847  (when (consp expr)
848    (if (and (eq (%car expr) 'nfunction)
849             (lambda-expression-p (cadr (%cdr expr))))
850      (fcomp-named-function (%caddr expr) (%cadr expr) env)
851      (if (and (eq (%car expr) 'function)
852               (lambda-expression-p (car (%cdr expr))))
853        (fcomp-named-function (%cadr expr) nil env)))))
854
855(defun fcomp-compile-toplevel-forms (env)
856  (when *fcomp-toplevel-forms*
857    (let* ((forms (nreverse *fcomp-toplevel-forms*))
858           (*fcomp-stream-position* *fcomp-previous-position*)
859           (lambda (if T ;; (null (cdr forms))
860                     `(lambda () ,@forms)
861                     `(lambda ()
862                        (macrolet ((load-time-value (value)
863                                     (declare (ignore value))
864                                     (compiler-function-overflow)))
865                          ,@forms)))))
866      (setq *fcomp-toplevel-forms* nil)
867      ;(format t "~& Random toplevel form: ~s" lambda)
868      (handler-case (fcomp-output-form
869                     $fasl-lfuncall
870                     env
871                     (fcomp-named-function lambda nil env))
872        (compiler-function-overflow ()
873          (if (null (cdr forms))
874            (error "Form ~s cannot be compiled - size exceeds compiler limitation"
875                   (%car forms))
876            ; else compile each half :
877            (progn
878              (dotimes (i (floor (length forms) 2))
879                (declare (fixnum i))
880                (push (pop forms) *fcomp-toplevel-forms*))
881              (fcomp-compile-toplevel-forms env)
882              (setq *fcomp-toplevel-forms* (nreverse forms))
883              (fcomp-compile-toplevel-forms env))))))))
884
885(defun fcomp-output-form (opcode env &rest args)
886  (when *fcomp-toplevel-forms* (fcomp-compile-toplevel-forms env))
887  (push (cons opcode args) *fcomp-output-list*))
888
889;;; Compile a lambda expression for the sole purpose of putting it in a fasl
890;;; file.  The result will not be funcalled.  This really shouldn't bother
891;;; making an lfun, but it's simpler this way...
892(defun fcomp-named-function (def name env)
893  (let* ((env (new-lexical-environment env))
894         (*nx-break-on-program-errors* (not (memq *fasl-break-on-program-errors* '(nil :defer)))))
895    (multiple-value-bind (lfun warnings)
896        (compile-named-function def
897                                :name name
898                                :env env
899                                :keep-lambda *fasl-save-definitions*
900                                :keep-symbols *fasl-save-local-symbols*
901                                :policy *default-file-compilation-policy*
902                                :load-time-eval-token cfasl-load-time-eval-sym
903                                :target *fasl-target*)
904      (fcomp-signal-or-defer-warnings warnings env)
905      lfun)))
906
907; For now, defer only UNDEFINED-FUNCTION-REFERENCEs, signal all others via WARN.
908; Well, maybe not WARN, exactly.
909(defun fcomp-signal-or-defer-warnings (warnings env)
910  (let ((init (null *fcomp-warnings-header*))
911        (some *fasl-warnings-signalled-p*)
912        (harsh *fasl-non-style-warnings-signalled-p*))
913    (dolist (w warnings)
914      (setf (compiler-warning-file-name w) *fasl-source-file*)
915      (setf (compiler-warning-stream-position w) *fcomp-stream-position*)
916      (if (and (typep w 'undefined-function-reference) 
917               (eq w (setq w (macro-too-late-p w env))))
918        (push w *fasl-deferred-warnings*)
919        (progn
920          (multiple-value-setq (harsh some *fcomp-warnings-header*)
921                               (signal-compiler-warning w init *fcomp-warnings-header* harsh some))
922          (setq init nil))))
923    (setq *fasl-warnings-signalled-p* some
924          *fasl-non-style-warnings-signalled-p* harsh)))
925
926; If W is an UNDEFINED-FUNCTION-REFERENCE which refers to a macro (either at compile-time in ENV
927; or globally), cons up a MACRO-USED-BEFORE-DEFINITION warning and return it; else return W.
928
929(defun macro-too-late-p (w env)
930  (let* ((args (compiler-warning-args w))
931         (name (car args)))
932    (if (or (macro-function name)
933            (let* ((defenv (definition-environment env))
934                   (info (if defenv (assq name (defenv.functions defenv)))))
935              (and (consp (cdr info))
936                   (eq 'macro (cadr info)))))
937      (make-instance 'macro-used-before-definition
938        :file-name (compiler-warning-file-name w)
939        :function-name (compiler-warning-function-name w)
940        :warning-type ':macro-used-before-definition
941        :args args)
942      w)))
943
944
945             
946;;;;          fasl-scan - dumping reference counting
947;;;;
948;;;;
949;These should be constants, but it's too much trouble when need to change 'em.
950(defparameter FASL-FILE-ID #xFF00)  ;Overall file format, shouldn't change much
951(defparameter FASL-VERSION #xFF54)  ;Fasl block format. ($fasl-vers)
952
953(defvar *fasdump-hash*)
954(defvar *fasdump-read-package*)
955(defvar *fasdump-global-offsets*)
956(defvar *make-load-form-hash*)
957
958;;;Return a hash table containing subexp's which are referenced more than once.
959(defun fasl-scan (forms)
960  (let* ((*fasdump-hash* (make-hash-table :size (length forms)          ; Crude estimate
961                                          :rehash-threshold 0.9
962                                          :test 'eq
963                                          :shared nil))
964         (*make-load-form-hash* (make-hash-table :test 'eq))
965         (*fasdump-read-package* nil)
966         (*fasdump-global-offsets* nil)
967         (gsymbols nil))
968    (dolist (op forms)
969      (if (packagep op) ; old magic treatment of *package*
970        (setq *fasdump-read-package* op)
971        (dolist (arg (cdr op)) (fasl-scan-form arg))))
972
973    #-bccl (when (eq *compile-verbose* :debug)
974             (format t "~&~S forms, ~S entries -> "
975                     (length forms)
976                     (hash-table-count *fasdump-hash*)))
977    (maphash #'(lambda (key val)
978                 (when (%izerop val) (remhash key *fasdump-hash*)))
979             *fasdump-hash*)
980    #-bccl (when (eq *compile-verbose* :debug)
981             (format t "~S." (hash-table-count *fasdump-hash*)))
982    (values *fasdump-hash*
983            gsymbols
984            *fasdump-global-offsets*)))
985
986;;; During scanning, *fasdump-hash* values are one of the following:
987;;;  nil - form hasn't been referenced yet.
988;;;   0 - form has been referenced exactly once
989;;;   T - form has been referenced more than once
990;;;  (load-form scanning-p referenced-p initform)
991;;;     form should be replaced by load-form
992;;;     scanning-p is true while we're scanning load-form
993;;;     referenced-p is nil if unreferenced,
994;;;                     T if referenced but not dumped yet,
995;;;                     0 if dumped already (fasl-dump-form uses this)
996;;;     initform is a compiled version of the user's initform
997(defun fasl-scan-form (form)
998  (when form
999    (let ((info (gethash form *fasdump-hash*)))
1000      (cond ((null info)
1001             (fasl-scan-dispatch form))
1002            ((eql info 0)
1003             (puthash form *fasdump-hash* t))
1004            ((listp info)               ; a make-load-form form
1005             (when (cadr info)
1006               (error "Circularity in ~S for ~S" 'make-load-form form))
1007             (let ((referenced-cell (cddr info)))
1008               (setf (car referenced-cell) t)   ; referenced-p
1009               (setf (gethash (car info) *fasdump-hash*) t)))))))
1010
1011
1012
1013
1014(defun fasl-scan-dispatch (exp)
1015  (when exp
1016    (let ((type-code (typecode exp)))
1017      (declare (fixnum type-code))
1018      (case type-code
1019        (#.target::tag-fixnum
1020         (fasl-scan-fixnum exp))
1021        (#.target::fulltag-cons (fasl-scan-list exp))
1022        #+ppc32-target
1023        (#.ppc32::tag-imm)
1024        #+ppc64-target
1025        ((#.ppc64::fulltag-imm-0
1026          #.ppc64::fulltag-imm-1
1027          #.ppc64::fulltag-imm-2
1028          #.ppc64::fulltag-imm-3))
1029        #+x8632-target
1030        (#.x8632::tag-imm)
1031        #+x8664-target
1032        ((#.x8664::fulltag-imm-0
1033          #.x8664::fulltag-imm-1))
1034        (t
1035         (if
1036           #+ppc32-target
1037           (= (the fixnum (logand type-code ppc32::full-tag-mask)) ppc32::fulltag-immheader)
1038           #+ppc64-target
1039           (= (the fixnum (logand type-code ppc64::lowtagmask)) ppc64::lowtag-immheader)
1040           #+x8632-target
1041           (= (the fixnum (logand type-code x8632::fulltagmask)) x8632::fulltag-immheader)
1042           #+x8664-target
1043           (and (= (the fixnum (lisptag exp)) x8664::tag-misc)
1044                (logbitp (the (unsigned-byte 16) (logand type-code x8664::fulltagmask))
1045                         (logior (ash 1 x8664::fulltag-immheader-0)
1046                                 (ash 1 x8664::fulltag-immheader-1)
1047                                 (ash 1 x8664::fulltag-immheader-2))))
1048           (case type-code
1049             ((#.target::subtag-macptr #.target::subtag-dead-macptr) (unless (%null-ptr-p exp) (fasl-unknown exp)))
1050             (t (fasl-scan-ref exp)))
1051           (case type-code
1052             ((#.target::subtag-pool #.target::subtag-weak #.target::subtag-lock) (fasl-unknown exp))
1053             (#+ppc-target #.target::subtag-symbol
1054              #+x8632-target #.target::subtag-symbol
1055              #+x8664-target #.target::tag-symbol (fasl-scan-symbol exp))
1056             ((#.target::subtag-instance #.target::subtag-struct)
1057              (fasl-scan-user-form exp))
1058             (#.target::subtag-package (fasl-scan-ref exp))
1059             (#.target::subtag-istruct
1060              (if (memq (istruct-type-name exp) *istruct-make-load-form-types*)
1061                (progn
1062                  (if (hash-table-p exp)
1063                    (fasl-lock-hash-table exp))
1064                  (fasl-scan-user-form exp))
1065                (fasl-scan-gvector exp)))
1066             #+x8632-target
1067             (#.target::subtag-function (fasl-scan-clfun exp))
1068             #+x8664-target
1069             (#.target::tag-function (fasl-scan-clfun exp))
1070             (t (fasl-scan-gvector exp)))))))))
1071             
1072
1073(defun fasl-scan-ref (form)
1074  (puthash form *fasdump-hash* 0))
1075
1076(defun fasl-scan-fixnum (fixnum)
1077  (unless (short-fixnum-p fixnum) (fasl-scan-ref fixnum)))
1078
1079(defparameter *istruct-make-load-form-types*
1080  '(lexical-environment shared-library-descriptor shared-library-entry-point
1081    external-entry-point foreign-variable
1082    ctype unknown-ctype class-ctype foreign-ctype union-ctype member-ctype 
1083    array-ctype numeric-ctype hairy-ctype named-ctype constant-ctype args-ctype
1084    hash-table package-ref type-cell class-cell slot-id))
1085
1086
1087
1088
1089(defun fasl-scan-gvector (vec)
1090  (fasl-scan-ref vec)
1091  (dotimes (i (uvsize vec)) 
1092    (declare (fixnum i))
1093    (fasl-scan-form (%svref vec i))))
1094
1095#+x86-target
1096(defun fasl-scan-clfun (f)
1097  (let* ((fv (function-to-function-vector f))
1098         (size (uvsize fv))
1099         (ncode-words (%function-code-words f)))
1100    (fasl-scan-ref f)
1101    (do* ((k ncode-words (1+ k)))
1102         ((= k size))
1103      (fasl-scan-form (uvref fv k)))))
1104
1105(defun funcall-lfun-p (form)
1106  (and (listp form)
1107       (eq (%car form) 'funcall)
1108       (listp (%cdr form))
1109       (or (functionp (%cadr form))
1110           (eql (typecode (%cadr form)) target::subtag-xfunction))
1111       (null (%cddr form))))
1112
1113;;; We currently represent istruct-cells as conses.  That's not
1114;;; incredibly efficient (among other things, we have to do this
1115;;; check when scanning/dumping any list), but it's probably not
1116;;; worth burning a tag on them.  There are currently about 50
1117;;; entries on the *istruct-cells* list.
1118(defun istruct-cell-p (x)
1119  (and (consp x)
1120       (typep (%car x) 'symbol)
1121       (atom (%cdr x))
1122       (not (null (memq x *istruct-cells*)))))
1123
1124(defun fasl-scan-list (list)
1125  (cond ((eq (%car list) cfasl-load-time-eval-sym)
1126         (let ((form (car (%cdr list))))
1127           (fasl-scan-form (if (funcall-lfun-p form)
1128                             (%cadr form)
1129                             form))))
1130        ((istruct-cell-p list)
1131         (fasl-scan-form (%car list)))
1132        (t (when list
1133             (fasl-scan-ref list)
1134             (fasl-scan-form (%car list))
1135             (fasl-scan-form (%cdr list))))))
1136
1137(defun fasl-scan-user-form (form)
1138  (multiple-value-bind (load-form init-form) (make-load-form form *fcomp-load-forms-environment*)
1139    (labels ((simple-load-form (form)
1140               (or (atom form)
1141                   (let ((function (car form)))
1142                     (or (eq function 'quote)
1143                         (and (symbolp function)
1144                              ;; using fboundp instead of symbol-function
1145                              ;; see comments in symbol-function
1146                              (or (functionp (fboundp function))
1147                                  (eq function 'progn))
1148                              ;; (every #'simple-load-form (cdr form))
1149                              (dolist (arg (cdr form) t)
1150                                (unless (simple-load-form arg)
1151                                  (return nil))))))))
1152             (load-time-eval-form (load-form form type)
1153               (cond ((quoted-form-p load-form)
1154                      (%cadr load-form))
1155                     ((self-evaluating-p load-form)
1156                      load-form)
1157                     ((simple-load-form load-form)
1158                      `(,cfasl-load-time-eval-sym ,load-form))
1159                     (t (multiple-value-bind (lfun warnings)
1160                                             (or
1161                                              (gethash load-form *make-load-form-hash*)
1162                                              (fcomp-named-function `(lambda () ,load-form) nil nil))
1163                          (when warnings
1164                            (cerror "Ignore the warnings"
1165                                    "Compiling the ~s ~a form for~%~s~%produced warnings."
1166                                    'make-load-form type form))
1167                          (setf (gethash load-form *make-load-form-hash*) lfun)
1168                          `(,cfasl-load-time-eval-sym (funcall ,lfun)))))))
1169      (declare (dynamic-extent #'simple-load-form #'load-time-eval-form))
1170      (let* ((compiled-initform
1171              (and init-form (load-time-eval-form init-form form "initialization")))
1172             (info (list (load-time-eval-form load-form form "creation")
1173                         T              ; scanning-p
1174                         nil            ; referenced-p
1175                         compiled-initform  ;initform-info
1176                         )))
1177        (puthash form *fasdump-hash* info)
1178        (fasl-scan-form (%car info))
1179        (setf (cadr info) nil)        ; no longer scanning load-form
1180        (when init-form
1181          (fasl-scan-form compiled-initform))))))
1182
1183(defun fasl-scan-symbol (form)
1184  (fasl-scan-ref form)
1185  (fasl-scan-form (symbol-package form)))
1186 
1187
1188
1189;;;;          Pass 3 - dumping
1190;;;;
1191;;;;
1192(defvar *fasdump-epush*)
1193(defvar *fasdump-stream*)
1194(defvar *fasdump-eref*)
1195
1196(defun fasl-dump-file (gnames goffsets forms hash filename)
1197  (let ((opened? nil)
1198        (finished? nil))
1199    (unwind-protect
1200      (with-open-file (*fasdump-stream* filename :direction :output
1201                                        :element-type '(unsigned-byte 8)
1202                                        :if-exists :supersede
1203                                        :if-does-not-exist :create)
1204        (setq opened? t)
1205        (fasl-set-filepos 0)
1206        (fasl-out-word 0)             ;Will become the ID word
1207        (fasl-out-word 1)             ;One block in the file
1208        (fasl-out-long 12)            ;Block starts at file pos 12
1209        (fasl-out-long 0)             ;Length will go here
1210        (fasl-dump-block gnames goffsets forms hash)  ;Write the block
1211        (let ((pos (fasl-filepos)))
1212          (fasl-set-filepos 8)        ;Back to length longword
1213          (fasl-out-long (- pos 12))) ;Write length
1214        (fasl-set-filepos 0)          ;Seem to have won, make us legal
1215        (fasl-out-word FASL-FILE-ID)
1216        (setq finished? t)
1217        filename)
1218      (when (and opened? (not finished?))
1219        (delete-file filename)))))
1220
1221(defun fasl-dump-block (gnames goffsets forms hash)
1222  (let ((etab-size (hash-table-count hash)))
1223    (when (> etab-size 65535)
1224      (error "Too many multiply-referenced objects in fasl file.~%Limit is ~d. Were ~d." 65535 etab-size))
1225    (fasl-out-word FASL-VERSION)          ; Word 0
1226    (fasl-out-long  0)
1227    (fasl-out-byte $fasl-vetab-alloc)
1228    (fasl-out-count etab-size)
1229    (fasl-dump gnames goffsets forms hash)
1230    (fasl-out-byte $fasl-end)))
1231
1232(defun fasl-dump (gnames goffsets forms hash)
1233  (let* ((*fasdump-hash* hash)
1234         (*fasdump-read-package* nil)
1235         (*fasdump-epush* nil)
1236         (*fasdump-eref* -1)
1237         (*fasdump-global-offsets* goffsets))
1238    (when gnames
1239      (fasl-out-byte $fasl-globals)
1240      (fasl-dump-form gnames))
1241    (dolist (op forms)
1242      (if (packagep op)
1243        (setq *fasdump-read-package* op)
1244        (progn
1245          (fasl-out-byte (car op))
1246          (dolist (arg (cdr op)) (fasl-dump-form arg)))))))
1247
1248;;;During dumping, *fasdump-hash* values are one of the following:
1249;;;   nil - form has no load form, is referenced at most once.
1250;;;   fixnum - form has already been dumped, fixnum is the etab index.
1251;;;   T - form hasn't been dumped yet, is referenced more than once.
1252;;;  (load-form . nil) - form should be replaced by load-form.
1253(defun fasl-dump-form (form)
1254  (let ((info (gethash form *fasdump-hash*)))
1255    (cond ((fixnump info)
1256           (fasl-out-byte $fasl-veref)
1257           (fasl-out-count info))
1258          ((consp info)
1259           (fasl-dump-user-form form info))
1260          (t
1261           (setq *fasdump-epush* info)
1262           (fasl-dump-dispatch form)))))
1263
1264(defun fasl-dump-user-form (form info)
1265  (let* ((load-form (car info))
1266         (referenced-p (caddr info))
1267         (initform (cadddr info)))
1268    (when referenced-p
1269      (unless (gethash load-form *fasdump-hash*)
1270        (error "~s was not in ~s.  This shouldn't happen." 'load-form '*fasdump-hash*)))
1271    (when initform
1272      (fasl-out-byte $fasl-prog1))      ; ignore the initform
1273    (fasl-dump-form load-form)
1274    (when referenced-p
1275      (setf (gethash form *fasdump-hash*) (gethash load-form *fasdump-hash*)))
1276    (when initform
1277      (fasl-dump-form initform))))
1278
1279(defun fasl-out-opcode (opcode form)
1280  (if *fasdump-epush*
1281    (progn
1282      (setq *fasdump-epush* nil)
1283      (fasl-out-byte (fasl-epush-op opcode))
1284      (fasl-dump-epush form))
1285    (fasl-out-byte opcode)))
1286
1287(defun fasl-dump-epush (form)
1288  #-bccl (when (fixnump (gethash form *fasdump-hash*))
1289           (error "Bug! Duplicate epush for ~S" form))
1290  (puthash form *fasdump-hash* (setq *fasdump-eref* (1+ *fasdump-eref*))))
1291
1292
1293(defun fasl-dump-dispatch (exp)
1294  (etypecase exp
1295    ((signed-byte 16) (fasl-dump-s16 exp))
1296    ((signed-byte 32) (fasl-dump-s32 exp))
1297    ((signed-byte 64) (fasl-dump-s64 exp))
1298    (bignum (fasl-dump-32-bit-ivector exp $fasl-bignum32))
1299    (character (fasl-dump-char exp))
1300    (list (fasl-dump-list exp))
1301    (immediate (fasl-dump-t_imm exp))
1302    (double-float (fasl-dump-dfloat exp))
1303    (single-float (fasl-dump-sfloat exp))
1304    (simple-string (let* ((n (length exp)))
1305                     (fasl-out-opcode $fasl-nvstr exp)
1306                     (fasl-out-count n)
1307                     (fasl-out-simple-string exp 0 n)))
1308    (simple-bit-vector (fasl-dump-bit-vector exp))
1309    ((simple-array (unsigned-byte 8) (*))
1310     (fasl-dump-8-bit-ivector exp $fasl-u8-vector))
1311    ((simple-array (signed-byte 8) (*))
1312     (fasl-dump-8-bit-ivector exp $fasl-s8-vector))
1313    ((simple-array (unsigned-byte 16) (*))
1314     (fasl-dump-16-bit-ivector exp $fasl-u16-vector))
1315    ((simple-array (signed-byte 16) (*))
1316     (fasl-dump-16-bit-ivector exp $fasl-s16-vector))
1317    ((simple-array (unsigned-byte 32) (*))
1318     (fasl-dump-32-bit-ivector exp $fasl-u32-vector))
1319    ((simple-array (signed-byte 32) (*))
1320     (fasl-dump-32-bit-ivector exp $fasl-s32-vector))
1321    ((simple-array single-float (*))
1322     (fasl-dump-32-bit-ivector exp $fasl-single-float-vector))
1323    ((simple-array double-float (*))
1324     (fasl-dump-double-float-vector exp))
1325    (symbol (fasl-dump-symbol exp))
1326    (package (fasl-dump-package exp))
1327    (function (fasl-dump-function exp))
1328    (xfunction (fasl-dump-function exp))
1329    (code-vector (fasl-dump-codevector exp))
1330    (xcode-vector (fasl-dump-codevector exp))
1331    (simple-vector (fasl-dump-gvector exp $fasl-t-vector))
1332    (ratio (fasl-dump-ratio exp))
1333    (complex (fasl-dump-complex exp))
1334    #+(and 64-bit-target (not cross-compiling))
1335    ((simple-array (unsigned-byte 64) (*))
1336     (fasl-dump-64-bit-ivector exp $fasl-u64-vector))
1337    #+(and 64-bit-target (not cross-compiling))
1338    ((simple-array (signed-byte 64) (*))
1339     (fasl-dump-64-bit-ivector exp $fasl-s64-vector))
1340    (ivector
1341     (unless (eq (backend-target-arch-name *target-backend*)
1342                 (backend-target-arch-name *host-backend*))
1343       (error "can't cross-compile constant reference to ~s" exp))
1344     (let* ((typecode (typecode exp))
1345            (n (uvsize exp))
1346            (nb (subtag-bytes typecode n)))
1347       (declare (fixnum n nb typecode))
1348       (fasl-out-opcode $fasl-vivec exp)
1349       (fasl-out-byte typecode)
1350       (fasl-out-count n)
1351       (fasl-out-ivect exp 0 nb)))
1352    (vector (fasl-dump-gvector exp $fasl-vector-header))
1353    (array (fasl-dump-gvector exp $fasl-array-header))
1354
1355    (gvector
1356     (if (= (typecode exp) target::subtag-istruct)
1357       (fasl-dump-gvector exp $fasl-istruct)
1358       (progn
1359         (unless (eq (backend-target-arch-name *target-backend*)
1360                     (backend-target-arch-name *host-backend*))
1361           (error "can't cross-compile constant reference to ~s" exp))
1362         (let* ((typecode (typecode exp))
1363                (n (uvsize exp)))
1364           (declare (fixnum n typecode))
1365           (fasl-out-opcode $fasl-vgvec exp)
1366           (fasl-out-byte typecode)
1367           (fasl-out-count n)
1368           (dotimes (i n)
1369             (fasl-dump-form (%svref exp i)))))))))
1370
1371(defun fasl-dump-gvector (v op)
1372  (let* ((n (uvsize v)))
1373    (fasl-out-opcode op v)
1374    (fasl-out-count n)
1375    (dotimes (i n)
1376      (fasl-dump-form (%svref v i)))))
1377
1378(defun fasl-dump-ratio (v)
1379  (fasl-out-opcode $fasl-ratio v)
1380  (fasl-dump-form (%svref v target::ratio.numer-cell))
1381  (fasl-dump-form (%svref v target::ratio.denom-cell)))
1382
1383(defun fasl-dump-complex (v)
1384  (fasl-out-opcode $fasl-complex v)
1385  (fasl-dump-form (%svref v target::complex.realpart-cell))
1386  (fasl-dump-form (%svref v target::complex.imagpart-cell)))
1387
1388(defun fasl-dump-bit-vector (v)
1389  (let* ((n (uvsize v)))
1390    (fasl-out-opcode $fasl-bit-vector v)
1391    (fasl-out-count n)
1392    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1393      (let* ((nb (ash (+ n 7) -3)))
1394        (fasl-out-ivect v 0 nb))
1395      (compiler-bug "need to byte-swap ~a" v))))
1396
1397(defun fasl-dump-8-bit-ivector (v op)
1398  (let* ((n (uvsize v)))
1399    (fasl-out-opcode op v)
1400    (fasl-out-count n)
1401    (let* ((nb n))
1402      (fasl-out-ivect v 0 nb))))
1403
1404(defun fasl-dump-16-bit-ivector (v op)
1405  (let* ((n (uvsize v)))
1406    (fasl-out-opcode op v)
1407    (fasl-out-count n)
1408    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1409      (let* ((nb (ash n 1)))
1410        (fasl-out-ivect v 0 nb))
1411      (dotimes (i n)
1412        (let* ((k (uvref v i)))
1413          (fasl-out-byte (ldb (byte 8 0) k))
1414          (fasl-out-byte (ldb (byte 8 8) k)))))))
1415
1416(defun fasl-dump-32-bit-ivector (v op)
1417  (let* ((n (uvsize v)))
1418    (fasl-out-opcode op v)
1419    (fasl-out-count n)
1420    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1421      (let* ((nb (ash n 2)))
1422        (fasl-out-ivect v 0 nb))
1423      (dotimes (i n)
1424        (let* ((k (uvref v i)))
1425          (fasl-out-byte (ldb (byte 8 0) k))
1426          (fasl-out-byte (ldb (byte 8 8) k))
1427          (fasl-out-byte (ldb (byte 8 16) k))
1428          (fasl-out-byte (ldb (byte 8 24) k)))))))
1429
1430
1431(defun fasl-dump-64-bit-ivector (v op)
1432  (let* ((n (uvsize v)))
1433    (fasl-out-opcode op v)
1434    (fasl-out-count n)
1435    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1436      (let* ((nb (ash n 3)))
1437        (fasl-out-ivect v 0 nb))
1438      (compiler-bug "need to byte-swap ~a" v))))
1439
1440(defun fasl-dump-double-float-vector (v)
1441  (let* ((n (uvsize v)))
1442    (fasl-out-opcode $fasl-double-float-vector v)
1443    (fasl-out-count n)
1444    (if (eq *fasl-host-big-endian* *fasl-target-big-endian*)
1445      (let* ((nb (ash n 3)))
1446        (fasl-out-ivect v (- target::misc-dfloat-offset
1447                             target::misc-data-offset) nb))
1448      (compiler-bug "need to byte-swap ~a" v))))
1449
1450;;; This is used to dump functions and "xfunctions".
1451;;; If we're cross-compiling, we shouldn't reference any
1452;;; (host) functions as constants; try to detect that
1453;;; case.
1454#-x86-target
1455(defun fasl-dump-function (f)
1456  (if (and (not (eq *fasl-backend* *host-backend*))
1457           (typep f 'function))
1458    (compiler-bug "Dumping a native function constant ~s during cross-compilation." f))
1459  (if (and (= (typecode f) target::subtag-xfunction)
1460           (= (typecode (uvref f 0)) target::subtag-u8-vector))
1461    (fasl-xdump-clfun f)
1462    (let* ((n (uvsize f)))
1463      (fasl-out-opcode $fasl-function f)
1464      (fasl-out-count n)
1465      (dotimes (i n)
1466        (fasl-dump-form (%svref f i))))))
1467
1468#+x86-target
1469(defun fasl-dump-function (f)
1470  (if (and (not (eq *fasl-backend* *host-backend*))
1471           (typep f 'function))
1472    (compiler-bug "Dumping a native function constant ~s during cross-compilation." f))
1473  (if (and (= (typecode f) target::subtag-xfunction)
1474           (= (typecode (uvref f 0)) target::subtag-u8-vector))
1475    (fasl-xdump-clfun f)
1476    (let* ((code-size (%function-code-words f))
1477           (function-vector (function-to-function-vector f))
1478           (function-size (uvsize function-vector)))
1479      (fasl-out-opcode $fasl-clfun f)
1480      (fasl-out-count function-size)
1481      (fasl-out-count code-size)
1482      (fasl-out-ivect function-vector 0 (ash code-size target::word-shift))
1483      (do* ((k code-size (1+ k)))
1484           ((= k function-size))
1485        (declare (fixnum k))
1486        (fasl-dump-form (uvref function-vector k))))))
1487       
1488
1489 
1490
1491;;; Write a "concatenated function".
1492(defun fasl-xdump-clfun (f)
1493  (target-arch-case
1494   (:x8632
1495    (let* ((code (uvref f 0))
1496           (function-size (ash (uvsize code) -2))
1497           (imm-words (dpb (uvref code 1) (byte 8 8) (uvref code 0)))
1498           (imm-bytes (ash imm-words 2))
1499           (other-words (- function-size imm-words)))
1500      (assert (= other-words (1- (uvsize f))))
1501      (fasl-out-opcode $fasl-clfun f)
1502      (fasl-out-count function-size)
1503      (fasl-out-count imm-words)
1504      (fasl-out-ivect code 0 imm-bytes)
1505      (do ((i 1 (1+ i))
1506           (n (uvsize f)))
1507          ((= i n))
1508        (declare (fixnum i n))
1509        (fasl-dump-form (%svref f i)))))
1510   (:x8664
1511    (let* ((code (uvref f 0))
1512           (code-size (dpb (uvref code 3)
1513                           (byte 8 24)
1514                           (dpb (uvref code 2)
1515                                (byte 8 16)
1516                                (dpb (uvref code 1)
1517                                     (byte 8 8)
1518                                     (uvref code 0)))))
1519           (function-size (ash (uvsize code) -3)))
1520      (assert (= (- function-size code-size) (1- (uvsize f))))
1521      (fasl-out-opcode $fasl-clfun f)
1522      (fasl-out-count function-size)
1523      (fasl-out-count code-size)
1524      (fasl-out-ivect code 0 (ash code-size 3))
1525      (do* ((i 1 (1+ i))
1526            (n (uvsize f)))
1527           ((= i n))
1528        (declare (fixnum i n))
1529        (fasl-dump-form (%svref f i)))))))
1530
1531(defun fasl-dump-codevector (c)
1532  (if (and (not (eq *fasl-backend* *host-backend*))
1533           (typep c 'code-vector))
1534    (compiler-bug "Dumping a native code-vector constant ~s during cross-compilation." c))
1535  (let* ((n (uvsize c)))
1536    (fasl-out-opcode $fasl-code-vector c)
1537    (fasl-out-count n)
1538    (fasl-out-ivect c)))
1539
1540(defun fasl-dump-t_imm (imm)
1541  (fasl-out-opcode $fasl-timm imm)
1542  (fasl-out-long (%address-of imm)))
1543
1544(defun fasl-dump-char (char)     ; << maybe not
1545  (let ((code (%char-code char)))
1546    (fasl-out-opcode $fasl-char char)
1547    (fasl-out-count code)))
1548
1549;;; Always write big-endian.
1550(defun fasl-dump-s16 (s16)
1551  (fasl-out-opcode $fasl-word-fixnum s16)
1552  (fasl-out-word s16))
1553
1554;;; Always write big-endian
1555(defun fasl-dump-s32 (s32)
1556  (fasl-out-opcode $fasl-s32 s32)
1557  (fasl-out-word (ldb (byte 16 16) s32))
1558  (fasl-out-word (ldb (byte 16 0) s32)))
1559
1560;;; Always write big-endian
1561(defun fasl-dump-s64 (s64)
1562  (fasl-out-opcode $fasl-s64 s64)
1563  (fasl-out-word (ldb (byte 16 48) s64))
1564  (fasl-out-word (ldb (byte 16 32) s64))
1565  (fasl-out-word (ldb (byte 16 16) s64))
1566  (fasl-out-word (ldb (byte 16 0) s64)))
1567
1568
1569
1570(defun fasl-dump-dfloat (float)
1571  (fasl-out-opcode $fasl-dfloat float)
1572  (multiple-value-bind (high low) (double-float-bits float)
1573    (fasl-out-long high)
1574    (fasl-out-long low)))
1575
1576(defun fasl-dump-sfloat (float)
1577  (fasl-out-opcode $fasl-sfloat float)
1578  (fasl-out-long (single-float-bits float)))
1579
1580
1581(defun fasl-dump-package (pkg)
1582  (let ((name (package-name pkg)))
1583    (fasl-out-opcode $fasl-nvpkg pkg)
1584    (fasl-out-nvstring name)))
1585
1586
1587
1588(defun fasl-dump-list (list)
1589  (cond ((null list) (fasl-out-opcode $fasl-nil list))
1590        ((eq (%car list) cfasl-load-time-eval-sym)
1591         (let* ((form (car (%cdr list)))
1592                (opcode $fasl-eval))
1593           (when (funcall-lfun-p form)
1594             (setq opcode $fasl-lfuncall
1595                   form (%cadr form)))
1596           (if *fasdump-epush*
1597             (progn
1598               (fasl-out-byte (fasl-epush-op opcode))
1599               (fasl-dump-form form)
1600               (fasl-dump-epush list))
1601             (progn
1602               (fasl-out-byte opcode)
1603               (fasl-dump-form form)))))
1604        ((istruct-cell-p list)
1605         (fasl-out-opcode $fasl-istruct-cell (car list))
1606         (fasl-dump-symbol (car list)))
1607        (t (fasl-dump-cons list))))
1608
1609(defun fasl-dump-cons (cons &aux (end cons) (cdr-len 0))
1610  (declare (fixnum cdr-len))
1611  (while (and (consp (setq end (%cdr end)))
1612              (null (gethash end *fasdump-hash*)))
1613    (incf cdr-len))
1614  (if (eql 0 cdr-len)
1615    (fasl-out-opcode $fasl-cons cons)
1616    (progn
1617      (fasl-out-opcode (if end $fasl-vlist* $fasl-vlist) cons)
1618      (fasl-out-count cdr-len)))
1619  (dotimes (i (the fixnum (1+ cdr-len)))
1620    (fasl-dump-form (%car cons))
1621    (setq cons (%cdr cons)))
1622  (when (or (eql 0 cdr-len) end)      ;cons or list*
1623    (fasl-dump-form end)))
1624
1625
1626
1627(defun fasl-dump-symbol (sym)
1628  (let* ((pkg (symbol-package sym))
1629         (name (symbol-name sym))
1630         (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)))
1631                (declare (fixnum i))
1632                (unless (zerop i) i))))
1633    (cond ((null pkg) 
1634           (progn 
1635             (fasl-out-opcode (if idx $fasl-nvmksym-special $fasl-nvmksym) sym)
1636             (fasl-out-nvstring name)))
1637          (*fasdump-epush*
1638           (progn
1639             (fasl-out-byte (fasl-epush-op (if idx
1640                                             $fasl-nvpkg-intern-special
1641                                             $fasl-nvpkg-intern)))
1642             (fasl-dump-form pkg)
1643             (fasl-dump-epush sym)
1644             (fasl-out-nvstring name)))
1645          (t
1646           (progn
1647             (fasl-out-byte (if idx
1648                              $fasl-nvpkg-intern-special
1649                              $fasl-nvpkg-intern))
1650             (fasl-dump-form pkg)
1651             (fasl-out-nvstring name))))))
1652
1653
1654(defun fasl-unknown (exp)
1655  (error "Can't dump ~S - unknown type" exp))
1656
1657(defun fasl-out-simple-string (str start end)
1658  (declare (simple-string str) (fixnum start end))
1659  (do* ((k start (1+ k)))
1660       ((= k end))
1661    (declare (fixnum k))
1662    (fasl-out-count (char-code (schar str k)))))
1663
1664(defun fasl-out-nvstring (str)
1665  (fasl-out-count (length str))
1666  (fasl-out-simple-string str 0 (length str)))
1667
1668(defun fasl-out-ivect (iv &optional 
1669                          (start 0) 
1670                          (nb 
1671                           (subtag-bytes (typecode iv) (uvsize iv))))
1672  (stream-write-ivector *fasdump-stream* iv start nb))
1673
1674
1675(defun fasl-out-long (long)
1676  (fasl-out-word (ash long -16))
1677  (fasl-out-word (logand long #xFFFF)))
1678
1679(defun fasl-out-word (word)
1680  (fasl-out-byte (ash word -8))
1681  (fasl-out-byte word))
1682
1683(defun fasl-out-byte (byte)
1684  (write-byte (%ilogand2 byte #xFF) *fasdump-stream*))
1685
1686;;; Write an unsigned integer in 7-bit chunks.
1687(defun fasl-out-count (val)
1688  (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val))
1689        (done nil))
1690       (done)
1691    (when (zerop (setq val (ash val -7)))
1692      (setq b (logior #x80 b) done t))
1693    (fasl-out-byte b)))
1694
1695(defun fasl-filepos ()
1696  (file-position *fasdump-stream*))
1697
1698(defun fasl-set-filepos (pos)
1699  (file-position *fasdump-stream* pos)
1700  #-bccl (unless (eq (file-position *fasdump-stream*) pos)
1701           (error "Unable to set file position to ~S" pos)))
1702
1703;;; Concatenate fasl files.
1704
1705;;; Format of a fasl file as expected by the fasloader.
1706;;;
1707;;; #xFF00         2 bytes - File version
1708;;; Block Count    2 bytes - Number of blocks in the file
1709;;; addr[0]        4 bytes - address of 0th block
1710;;; length[0]      4 bytes - length of 0th block
1711;;; addr[1]        4 bytes - address of 1st block
1712;;; length[1]      4 bytes - length of 1st block
1713;;; ...
1714;;; addr[n-1]      4 bytes
1715;;; length[n-1]    4 bytes
1716;;; length[0] + length[1] + ... + length [n-1] bytes of data
1717
1718;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1719;;
1720;; (fasl-concatenate out-file fasl-files &key :if-exists)
1721;;
1722;; out-file     name of file in which to store the concatenation
1723;; fasl-files   list of names of fasl files to concatenate
1724;; if-exists    as for OPEN, defaults to :error
1725;;
1726;; function result: pathname to the output file.
1727;; It works to use the output of one invocation of fasl-concatenate
1728;; as an input of another invocation.
1729;;
1730(defun fasl-concatenate (out-file fasl-files &key (if-exists :error))
1731  (%fasl-concatenate out-file fasl-files if-exists (pathname-type *.fasl-pathname*)))
1732
1733(defun %fasl-concatenate (out-file fasl-files if-exists file-ext)
1734  (let ((count 0)
1735        (created? nil)
1736        (finished? nil)
1737        (ext-pathname (make-pathname :type file-ext)))
1738    (declare (fixnum count))
1739    (flet ((fasl-read-halfword (f)
1740             (dpb (read-byte f) (byte 8 8) (read-byte f)))
1741           (fasl-write-halfword (h f)
1742             (write-byte (ldb (byte 8 8) h) f)
1743             (write-byte (ldb (byte 8 0) h) f)
1744             h))
1745      (flet ((fasl-read-fullword (f)
1746               (dpb (fasl-read-halfword f) (byte 16 16) (fasl-read-halfword f)))
1747             (fasl-write-fullword (w f)
1748               (fasl-write-halfword (ldb (byte 16 16) w) f)
1749               (fasl-write-halfword (ldb (byte 16 0) w) f)
1750               w))
1751        (dolist (file fasl-files)
1752          (setq file (merge-pathnames file ext-pathname))
1753          (unless (equal (pathname-type file) file-ext)
1754            (error "Not a ~A file: ~s" file-ext file))
1755          (with-open-file (instream file :element-type '(unsigned-byte 8))
1756            (unless (eql fasl-file-id (fasl-read-halfword instream))
1757              (error "Bad ~A file ID in ~s" file-ext file))
1758            (incf count (fasl-read-halfword instream))))
1759        (unwind-protect
1760             (with-open-file (outstream
1761                              (setq out-file (merge-pathnames out-file ext-pathname))
1762                              :element-type '(unsigned-byte 8)
1763                              :direction :output
1764                              :if-does-not-exist :create
1765                              :if-exists if-exists)
1766               (setq created? t)
1767               (let ((addr-address 4)
1768                     (data-address (+ 4 (* count 8))))
1769                 (fasl-write-halfword 0 outstream) ;  will be $fasl-id
1770                 (fasl-write-halfword count outstream)
1771                 (dotimes (i (* 2 count))
1772                   (fasl-write-fullword 0 outstream)) ; for addresses/lengths
1773                 (dolist (file fasl-files)
1774                   (with-open-file (instream (merge-pathnames file ext-pathname)
1775                                             :element-type '(unsigned-byte 8))
1776                     (fasl-read-halfword instream) ; skip ID
1777                     (let* ((fasl-count (fasl-read-halfword instream))
1778                            (addrs (make-array fasl-count))
1779                            (sizes (make-array fasl-count))
1780                            addr0)
1781                       (declare (fixnum fasl-count)
1782                                (dynamic-extent addrs sizes))
1783                       (dotimes (i fasl-count)
1784                         (setf (svref addrs i) (fasl-read-fullword instream)
1785                               (svref sizes i) (fasl-read-fullword instream)))
1786                       (setq addr0 (svref addrs 0))
1787                       (file-position outstream addr-address)
1788                       (dotimes (i fasl-count)
1789                         (fasl-write-fullword
1790                          (+ data-address (- (svref addrs i) addr0))
1791                          outstream)
1792                         (fasl-write-fullword (svref sizes i) outstream)
1793                         (incf addr-address 8))
1794                       (file-position outstream data-address)
1795                       (dotimes (i fasl-count)
1796                         (file-position instream (svref addrs i))
1797                         (let ((fasl-length (svref sizes i)))
1798                           (dotimes (j fasl-length)
1799                             (write-byte (read-byte instream) outstream))
1800                           (incf data-address fasl-length))))))
1801                 (stream-length outstream data-address)
1802                 (file-position outstream 0)
1803                 (fasl-write-halfword fasl-file-id outstream)
1804                 (setq finished? t)))
1805          (when (and created? (not finished?))
1806            (delete-file out-file))))
1807      out-file)))
1808
1809;;; Cross-compilation environment stuff.  Some of this involves
1810;;; setting up the TARGET and OS packages.
1811(defun ensure-package-nickname (name package)
1812  (let* ((old (find-package name)))
1813    (unless (eq old package)
1814      (rename-package old (package-name old) (delete name (package-nicknames old) :test #'string=))
1815      (rename-package package (package-name package) (cons name (package-nicknames package)))
1816      old)))
1817
1818(defmacro with-cross-compilation-package ((name target) &body body)
1819  (let* ((old-package (gensym))
1820         (name-var (gensym))
1821         (target-var (gensym)))
1822    `(let* ((,name-var ,name)
1823            (,target-var ,target)
1824            (,old-package (ensure-package-nickname ,name-var ,target-var)))
1825      (unwind-protect
1826           (progn ,@body)
1827        (when ,old-package (ensure-package-nickname ,name-var
1828                                                          ,old-package))))))
1829
1830(defun %with-cross-compilation-target (target thunk)
1831  (let* ((backend (find-backend target)))
1832    (if (null backend)
1833      (error "No known compilation target named ~s." target)
1834      (let* ((arch (backend-target-arch backend))
1835             (arch-package-name (arch::target-package-name arch))
1836             (ftd (backend-target-foreign-type-data backend))
1837             (ftd-package-name (ftd-interface-package-name ftd)))
1838        (or (find-package arch-package-name)
1839            (make-package arch-package-name))
1840        (or (find-package ftd-package-name)
1841            (make-package ftd-package-name :use "COMMON-LISP"))
1842        (with-cross-compilation-package ("OS" ftd-package-name)
1843          (with-cross-compilation-package ("TARGET" arch-package-name)
1844            (let* ((*target-ftd* ftd))
1845               (funcall thunk))))))))
1846
1847(defmacro with-cross-compilation-target ((target) &body body)
1848  `(%with-cross-compilation-target ,target #'(lambda () ,@body)))
1849             
1850
1851 
1852
1853(provide 'nfcomp)
1854
Note: See TracBrowser for help on using the repository browser.