source: trunk/source/lib/nfcomp.lisp @ 11420

Last change on this file since 11420 was 11420, checked in by gz, 12 years ago

Remove obsolete bootstrapping code, fix indentation

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