source: branches/qres/ccl/lib/nfcomp.lisp @ 14164

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

arrange so don't output coverage acode for compiler-generated toplevel forms

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