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

Last change on this file since 8995 was 8995, checked in by gb, 12 years ago

Are you as annoyed at the mere presence of DEFINE-COMPILE-TIME-SYMBOL-MADRO
as I am ?
Change what gets recorded by DEFINE-COMPILE-TIME-MACRO.

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