source: branches/working-0711/ccl/lib/nfcomp.lisp @ 12154

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

allow compound type specifiers as declarations identifiers. consistently do not allow unknown types as declaration identifers (i.e. report them as a bad declaration rather than unknown type)

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