source: branches/gz-working/lib/nfcomp.lisp @ 8505

Last change on this file since 8505 was 8505, checked in by gz, 13 years ago

checkpoint work in progress, mainly some final cleanup, reorg, don't try to track atoms, keep track of source through transforms; reporting implementation in library;cover.lisp

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