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

Last change on this file since 11279 was 11279, checked in by gz, 13 years ago

Backport compiler source location changes from trunk, mostly reorg and move file-compiler stuff out of the compiler, but also a fix to record a source note for inner functions

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