src/cold/compile-cold-sbcl.lisp

   1 ;;;; Compile the fundamental system sources (not CLOS, and possibly
   2 ;;;; not some other warm-load-only stuff like DESCRIBE) to produce
   3 ;;;; object files. Also set *TARGET-OBJECT-FILES* to all of their
   4 ;;;; names.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB-COLD")
  16
  17 (let ((*features* (cons :sb-xc *features*)))
  18   (load "src/cold/muffler.lisp"))
  19
  20 ;; Avoid forward-reference to an as-yet unknown type.
  21 ;; NB: This is not how you would write this function, if you required
  22 ;; such a thing. It should be (TYPEP X 'CODE-DELETION-NOTE).
  23 ;; Do as I say, not as I do.
  24 (defun code-deletion-note-p (x)
  25   (eq (type-of x) 'sb!ext:code-deletion-note))
  26 (setq sb!c::*handled-conditions*
  27       `((,(sb!kernel:specifier-type
  28            '(or (satisfies unable-to-optimize-note-p)
  29                 (satisfies code-deletion-note-p)))
  30          . muffle-warning)))
  31
  32 (defun proclaim-target-optimization ()
  33   (let ((debug (if (position :sb-show *shebang-features*) 2 1)))
  34     (sb!xc:proclaim
  35      `(optimize
  36        (compilation-speed 1) (debug ,debug)
  37        ;; CLISP's pretty-printer is fragile and tends to cause stack
  38        ;; corruption or fail internal assertions, as of 2003-04-20; we
  39        ;; therefore turn off as many notes as possible.
  40        (sb!ext:inhibit-warnings #-clisp 2 #+clisp 3)
  41        ;; SAFETY = SPEED (and < 3) should provide reasonable safety,
  42        ;; but might skip some unreasonably expensive stuff
  43        ;; (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2).
  44        (safety 2) (space 1) (speed 2)
  45        ;; sbcl-internal optimization declarations:
  46        ;;
  47        ;; never insert stepper conditions
  48        (sb!c:insert-step-conditions 0)
  49        ;; save FP and PC for alien calls -- or not
  50        (sb!c:alien-funcall-saves-fp-and-pc #!+x86 3 #!-x86 0)))))
  51
  52 (defun in-target-cross-compilation-mode (fun)
  53   "Call FUN with everything set up appropriately for cross-compiling
  54    a target file."
  55   (let (;; In order to increase microefficiency of the target Lisp,
  56         ;; enable old CMU CL defined-function-types-never-change
  57         ;; optimizations. (ANSI says users aren't supposed to
  58         ;; redefine our functions anyway; and developers can
  59         ;; fend for themselves.)
  60         #!-sb-fluid
  61         (sb!ext:*derive-function-types* t)
  62         ;; Let the target know that we're the cross-compiler.
  63         (*features* (cons :sb-xc *features*))
  64         ;; We need to tweak the readtable..
  65         (*readtable* (copy-readtable)))
  66     ;; ..in order to make backquotes expand into target code
  67     ;; instead of host code.
  68     (set-macro-character #\` #'sb!impl::backquote-charmacro)
  69     (set-macro-character #\, #'sb!impl::comma-charmacro)
  70
  71     (set-dispatch-macro-character #\# #\+ #'she-reader)
  72     (set-dispatch-macro-character #\# #\- #'she-reader)
  73     ;; Control optimization policy.
  74     (proclaim-target-optimization)
  75     (progn
  76       (funcall fun))))
  77
  78 (setf *target-compile-file* #'sb!xc:compile-file)
  79 (setf *target-assemble-file* #'sb!c:assemble-file)
  80 (setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode)
  81 \f
  82 ;; ... and since the cross-compiler hasn't seen a DEFMACRO for QUASIQUOTE,
  83 ;; make it think it has, otherwise it fails more-or-less immediately.
  84 (setf (sb!xc:macro-function 'sb!int:quasiquote)
  85       (lambda (form env)
  86         (the sb!kernel:lexenv-designator env)
  87         (sb!impl::expand-quasiquote (second form) t)))
  88
  89 (setq sb!c::*track-full-called-fnames* :minimal) ; Change this as desired
  90
  91 ;;; Keep these in order by package, then symbol.
  92 (dolist (sym
  93          (append
  94           ;; CL, EXT, KERNEL
  95           '(allocate-instance
  96             compute-applicable-methods
  97             slot-makunbound
  98             make-load-form-saving-slots
  99             sb!ext:run-program
 100             sb!vm::map-allocated-objects
 101             sb!vm::map-objects-in-range
 102             sb!kernel::choose-code-component-order)
 103           ;; CLOS implementation
 104           '(sb!mop:class-finalized-p
 105             sb!mop:class-prototype
 106             sb!mop:class-slots
 107             sb!mop:eql-specializer-object
 108             sb!mop:finalize-inheritance
 109             sb!mop:generic-function-name
 110             (setf sb!mop:generic-function-name)
 111             sb!mop:slot-definition-allocation
 112             sb!mop:slot-definition-name
 113             sb!pcl::%force-cache-flushes
 114             sb!pcl::check-wrapper-validity
 115             sb!pcl::class-has-a-forward-referenced-superclass-p
 116             sb!pcl::class-wrapper
 117             sb!pcl::compute-gf-ftype
 118             sb!pcl::definition-source
 119             sb!pcl::ensure-accessor
 120             sb!pcl:ensure-class-finalized)
 121           ;; CLOS-based packages
 122           '(sb!gray:stream-clear-input
 123             sb!gray:stream-clear-output
 124             sb!gray:stream-file-position
 125             sb!gray:stream-finish-output
 126             sb!gray:stream-force-output
 127             sb!gray:stream-fresh-line
 128             sb!gray:stream-line-column
 129             sb!gray:stream-line-length
 130             sb!gray:stream-listen
 131             sb!gray:stream-peek-char
 132             sb!gray:stream-read-byte
 133             sb!gray:stream-read-char
 134             sb!gray:stream-read-char-no-hang
 135             sb!gray:stream-read-line
 136             sb!gray:stream-read-sequence
 137             sb!gray:stream-terpri
 138             sb!gray:stream-unread-char
 139             sb!gray:stream-write-byte
 140             sb!gray:stream-write-char
 141             sb!gray:stream-write-sequence
 142             sb!gray:stream-write-string
 143             sb!sequence:concatenate
 144             sb!sequence:copy-seq
 145             sb!sequence:count
 146             sb!sequence:count-if
 147             sb!sequence:count-if-not
 148             sb!sequence:delete
 149             sb!sequence:delete-duplicates
 150             sb!sequence:delete-if
 151             sb!sequence:delete-if-not
 152             (setf sb!sequence:elt)
 153             sb!sequence:elt
 154             sb!sequence:emptyp
 155             sb!sequence:fill
 156             sb!sequence:find
 157             sb!sequence:find-if
 158             sb!sequence:find-if-not
 159             (setf sb!sequence:iterator-element)
 160             sb!sequence:iterator-endp
 161             sb!sequence:iterator-step
 162             sb!sequence:length
 163             sb!sequence:make-sequence-iterator
 164             sb!sequence:make-sequence-like
 165             sb!sequence:map
 166             sb!sequence:merge
 167             sb!sequence:mismatch
 168             sb!sequence:nreverse
 169             sb!sequence:nsubstitute
 170             sb!sequence:nsubstitute-if
 171             sb!sequence:nsubstitute-if-not
 172             sb!sequence:position
 173             sb!sequence:position-if
 174             sb!sequence:position-if-not
 175             sb!sequence:reduce
 176             sb!sequence:remove
 177             sb!sequence:remove-duplicates
 178             sb!sequence:remove-if
 179             sb!sequence:remove-if-not
 180             sb!sequence:replace
 181             sb!sequence:reverse
 182             sb!sequence:search
 183             sb!sequence:sort
 184             sb!sequence:stable-sort
 185             sb!sequence:subseq
 186             sb!sequence:substitute
 187             sb!sequence:substitute-if
 188             sb!sequence:substitute-if-not)
 189           ;; Fast interpreter
 190           #!+sb-fasteval
 191           '(sb!interpreter:%fun-type
 192             sb!interpreter:env-policy
 193             sb!interpreter:eval-in-environment
 194             sb!interpreter:find-lexical-fun
 195             sb!interpreter:find-lexical-var
 196             sb!interpreter::flush-everything
 197             sb!interpreter::fun-lexically-notinline-p
 198             sb!interpreter:lexenv-from-env
 199             sb!interpreter::lexically-unlocked-symbol-p
 200             sb!interpreter:list-locals
 201             sb!interpreter:prepare-for-compile
 202             sb!interpreter::reconstruct-syntactic-closure-env)
 203           ;; Other
 204           '(sb!debug::find-interrupted-name-and-frame
 205             sb!impl::encapsulate-generic-function
 206             sb!impl::encapsulated-generic-function-p
 207             sb!impl::get-processes-status-changes
 208             sb!impl::step-form
 209             sb!impl::step-values
 210             sb!impl::stringify-package-designator
 211             sb!impl::stringify-string-designator
 212             sb!impl::stringify-string-designators
 213             sb!impl::unencapsulate-generic-function)))
 214   (setf (gethash sym sb!c::*undefined-fun-whitelist*) t))
 215
 216 (defvar *target-object-file-names*)
 217
 218 #+#.(cl:if (cl:find-package "SB-POSIX") '(and) '(or))
 219 (defun parallel-make-host-2 (max-jobs)
 220   (let ((reversed-target-object-file-names nil)
 221         (subprocess-count 0)
 222         (subprocess-list nil))
 223     (flet ((wait ()
 224              (multiple-value-bind (pid status) (sb-posix:wait)
 225                (format t "~&; Subprocess ~D exit status ~D~%"  pid status)
 226                (setq subprocess-list (delete pid subprocess-list)))
 227              (decf subprocess-count)))
 228       (do-stems-and-flags (stem flags)
 229         (unless (position :not-target flags)
 230           (when (>= subprocess-count max-jobs)
 231             (wait))
 232           (let ((pid (sb-posix:fork)))
 233             (when (zerop pid)
 234               (target-compile-stem stem flags)
 235               ;; FIXME: convey exit code based on COMPILE result.
 236               (sb-cold::exit-process 0))
 237             (push pid subprocess-list))
 238           (incf subprocess-count)
 239           ;; Cause the compile-time effects from this file
 240           ;; to appear in subsequently forked children.
 241           (let ((*compile-for-effect-only* t))
 242             (target-compile-stem stem flags))
 243           (unless (find :not-genesis flags)
 244             (push (stem-object-path stem flags :target-compile)
 245                   reversed-target-object-file-names))))
 246       (loop (if (plusp subprocess-count) (wait) (return)))
 247       (nreverse reversed-target-object-file-names))))
 248
 249 ;;; Actually compile
 250 (setf *target-object-file-names*
 251       (if (make-host-2-parallelism)
 252           (parallel-make-host-2 (make-host-2-parallelism))
 253           (let ((reversed-target-object-file-names nil))
 254             (do-stems-and-flags (stem flags)
 255               (unless (position :not-target flags)
 256                 (let ((filename (target-compile-stem stem flags)))
 257                   (unless (position :not-genesis flags)
 258                     (push filename reversed-target-object-file-names)))
 259                 #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
 260             (nreverse reversed-target-object-file-names))))