source: release/1.3/source/lib/nfcomp.lisp @ 11814

Last change on this file since 11814 was 11814, checked in by rme, 11 years ago

Merge trunk changes r11790-r11794, r11796, r11801, r11803

(GC fixes, additional x8632 vinsns, easygui enhancements, x8632 callback fix)

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