source: trunk/source/lib/nfcomp.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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