source: branches/working-0711-perf/ccl/lib/nfcomp.lisp @ 9434

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

Compile-time DEFMACRO is supposed to make it a little clearer that
a macro's defined, for the benefit of things that processs deferred
warnings/resolve forward-refs.

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