source: branches/ia32/lib/nfcomp.lisp @ 9543

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

fasl-scan-dispatch: Call fasl-scan-clfun on x8632 functions.

fasl-scan-clfun: use archmacro function-to-function-vector.

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