source: branches/purify/source/lib/nfcomp.lisp @ 13219

Last change on this file since 13219 was 13219, checked in by gb, 11 years ago

Try to save strings in ASCII if possible.

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