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     ;; Specify where target machinery lives.
  76     (with-additional-nickname ("SB-XC" "SB!XC")
  77       (funcall fun))))
  78
  79 (setf *target-compile-file* #'sb-xc:compile-file)
  80 (setf *target-assemble-file* #'sb!c:assemble-file)
  81 (setf *in-target-compilation-mode-fn* #'in-target-cross-compilation-mode)
  82 \f
  83 ;; ... and since the cross-compiler hasn't seen a DEFMACRO for QUASIQUOTE,
  84 ;; make it think it has, otherwise it fails more-or-less immediately.
  85 (setf (sb-xc:macro-function 'sb!int:quasiquote)
  86       (lambda (form env)
  87         (the sb!kernel:lexenv-designator env)
  88         (sb!impl::expand-quasiquote (second form) t)))
  89
  90 (setq sb!c::*track-full-called-fnames* :minimal) ; Change this as desired
  91
  92 ;;; Keep these in order by package, then symbol.
  93 (dolist (sym
  94          (append
  95           ;; CL, EXT, KERNEL
  96           '(allocate-instance
  97             compute-applicable-methods
  98             slot-makunbound
  99             make-load-form-saving-slots
 100             sb!ext:run-program
 101             sb!vm::map-allocated-objects
 102             sb!vm::map-objects-in-range
 103             sb!kernel::choose-code-component-order)
 104           ;; CLOS implementation
 105           '(sb!mop:class-finalized-p
 106             sb!mop:class-prototype
 107             sb!mop:class-slots
 108             sb!mop:eql-specializer-object
 109             sb!mop:finalize-inheritance
 110             sb!mop:generic-function-name
 111             (setf sb!mop:generic-function-name)
 112             sb!mop:slot-definition-allocation
 113             sb!mop:slot-definition-name
 114             sb!pcl::%force-cache-flushes
 115             sb!pcl::check-wrapper-validity
 116             sb!pcl::class-has-a-forward-referenced-superclass-p
 117             sb!pcl::class-wrapper
 118             sb!pcl::compute-gf-ftype
 119             sb!pcl::definition-source
 120             sb!pcl::ensure-accessor
 121             sb!pcl:ensure-class-finalized)
 122           ;; CLOS-based packages
 123           '(sb!gray:stream-clear-input
 124             sb!gray:stream-clear-output
 125             sb!gray:stream-file-position
 126             sb!gray:stream-finish-output
 127             sb!gray:stream-force-output
 128             sb!gray:stream-fresh-line
 129             sb!gray:stream-line-column
 130             sb!gray:stream-line-length
 131             sb!gray:stream-listen
 132             sb!gray:stream-peek-char
 133             sb!gray:stream-read-byte
 134             sb!gray:stream-read-char
 135             sb!gray:stream-read-char-no-hang
 136             sb!gray:stream-read-line
 137             sb!gray:stream-read-sequence
 138             sb!gray:stream-terpri
 139             sb!gray:stream-unread-char
 140             sb!gray:stream-write-byte
 141             sb!gray:stream-write-char
 142             sb!gray:stream-write-sequence
 143             sb!gray:stream-write-string
 144             sb!sequence:concatenate
 145             sb!sequence:copy-seq
 146             sb!sequence:count
 147             sb!sequence:count-if
 148             sb!sequence:count-if-not
 149             sb!sequence:delete
 150             sb!sequence:delete-duplicates
 151             sb!sequence:delete-if
 152             sb!sequence:delete-if-not
 153             (setf sb!sequence:elt)
 154             sb!sequence:elt
 155             sb!sequence:emptyp
 156             sb!sequence:fill
 157             sb!sequence:find
 158             sb!sequence:find-if
 159             sb!sequence:find-if-not
 160             (setf sb!sequence:iterator-element)
 161             sb!sequence:iterator-endp
 162             sb!sequence:iterator-step
 163             sb!sequence:length
 164             sb!sequence:make-sequence-iterator
 165             sb!sequence:make-sequence-like
 166             sb!sequence:map
 167             sb!sequence:merge
 168             sb!sequence:mismatch
 169             sb!sequence:nreverse
 170             sb!sequence:nsubstitute
 171             sb!sequence:nsubstitute-if
 172             sb!sequence:nsubstitute-if-not
 173             sb!sequence:position
 174             sb!sequence:position-if
 175             sb!sequence:position-if-not
 176             sb!sequence:reduce
 177             sb!sequence:remove
 178             sb!sequence:remove-duplicates
 179             sb!sequence:remove-if
 180             sb!sequence:remove-if-not
 181             sb!sequence:replace
 182             sb!sequence:reverse
 183             sb!sequence:search
 184             sb!sequence:sort
 185             sb!sequence:stable-sort
 186             sb!sequence:subseq
 187             sb!sequence:substitute
 188             sb!sequence:substitute-if
 189             sb!sequence:substitute-if-not)
 190           ;; Fast interpreter
 191           #!+sb-fasteval
 192           '(sb!interpreter:%fun-type
 193             sb!interpreter:env-policy
 194             sb!interpreter:eval-in-environment
 195             sb!interpreter:find-lexical-fun
 196             sb!interpreter:find-lexical-var
 197             sb!interpreter::flush-everything
 198             sb!interpreter::fun-lexically-notinline-p
 199             sb!interpreter:lexenv-from-env
 200             sb!interpreter::lexically-unlocked-symbol-p
 201             sb!interpreter:list-locals
 202             sb!interpreter:prepare-for-compile
 203             sb!interpreter::reconstruct-syntactic-closure-env)
 204           ;; Other
 205           '(sb!debug::find-interrupted-name-and-frame
 206             sb!impl::encapsulate-generic-function
 207             sb!impl::encapsulated-generic-function-p
 208             sb!impl::get-processes-status-changes
 209             sb!impl::step-form
 210             sb!impl::step-values
 211             sb!impl::stringify-package-designator
 212             sb!impl::stringify-string-designator
 213             sb!impl::stringify-string-designators
 214             sb!impl::unencapsulate-generic-function)))
 215   (setf (gethash sym sb!c::*undefined-fun-whitelist*) t))
 216
 217 (defvar *target-object-file-names*)
 218
 219 #+#.(cl:if (cl:find-package "SB-POSIX") '(and) '(or))
 220 (defun parallel-make-host-2 (max-jobs)
 221   (let ((reversed-target-object-file-names nil)
 222         (subprocess-count 0)
 223         (subprocess-list nil))
 224     (flet ((wait ()
 225              (multiple-value-bind (pid status) (sb-posix:wait)
 226                (format t "~&; Subprocess ~D exit status ~D~%"  pid status)
 227                (setq subprocess-list (delete pid subprocess-list)))
 228              (decf subprocess-count)))
 229       (do-stems-and-flags (stem flags)
 230         (unless (position :not-target flags)
 231           (when (>= subprocess-count max-jobs)
 232             (wait))
 233           (let ((pid (sb-posix:fork)))
 234             (when (zerop pid)
 235               (target-compile-stem stem flags)
 236               ;; FIXME: convey exit code based on COMPILE result.
 237               (sb-cold::exit-process 0))
 238             (push pid subprocess-list))
 239           (incf subprocess-count)
 240           ;; Cause the compile-time effects from this file
 241           ;; to appear in subsequently forked children.
 242           (let ((*compile-for-effect-only* t))
 243             (target-compile-stem stem flags))
 244           (unless (find :not-genesis flags)
 245             (push (stem-object-path stem flags :target-compile)
 246                   reversed-target-object-file-names))))
 247       (loop (if (plusp subprocess-count) (wait) (return)))
 248       (nreverse reversed-target-object-file-names))))
 249
 250 ;;; Actually compile
 251 (setf *target-object-file-names*
 252       (if (make-host-2-parallelism)
 253           (parallel-make-host-2 (make-host-2-parallelism))
 254           (let ((reversed-target-object-file-names nil))
 255             (do-stems-and-flags (stem flags)
 256               (unless (position :not-target flags)
 257                 (let ((filename (target-compile-stem stem flags)))
 258                   (unless (position :not-genesis flags)
 259                     (push filename reversed-target-object-file-names)))
 260                 #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
 261             (nreverse reversed-target-object-file-names))))