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

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

Extend the mechanism used for keeping track of definitions (previously used only for inlining and undefined function warnings) to make it work across compilation units rather than just per file and make it also keep track of method definitions. Make it use a hash table since now the set of definitions can get quite large. Use it to detect and issue warnings about duplicate function or method definitions inside a compilation unit.

One side-effect of above changes is that compile-time inlining information is kept across the whole compilation unit rather than being per-file only.

Fixes in defstruct, to make sure predicate def gets noted, and to make accessor defs only get noted once.

Add (and export) a new CCL:WITHOUT-DUPLICATE-DEFINITION-WARNINGS macro that can be wrapped around intentional duplicate definitions to avoid the warning.

New NLAMBDA macro, which is to LAMBDA as NFUNCTION is to FUNCTION. Not exported.

Wrap with-compilation-unit around compile-ccl and xcompile-ccl.

Remove a half-dozen or so unintentional duplicate definitions in ccl, and work around the intentional ones by either using fset instead of defun at the first definition or wrapping the second one in without-duplicate-definition-warnings.

In file compiler, do not use the file's lexical environment for compile-time evaluation!

Make report-compiler-warning show the file position, when known, for warnings in anonymous lambdas.

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