src/cold/defun-load-or-cload-xcompiler.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB-COLD")
  11
  12 (defparameter *full-calls-to-warn-about*
  13   '(;mask-signed-field ;; Too many to fix
  14     ))
  15
  16 ;;; Set of function names whose definition will never be seen in make-host-2,
  17 ;;; as they are deferred until warm load.
  18 ;;; The table is populated later in this file.
  19 (defparameter *undefined-fun-whitelist* (make-hash-table :test 'equal))
  20
  21 #+#.(cl:if (cl:find-package "SB-POSIX") '(and) '(or))
  22 (defun parallel-make-host-1 (max-jobs)
  23   (let ((subprocess-count 0)
  24         (subprocess-list nil))
  25     (flet ((wait ()
  26              (multiple-value-bind (pid status) (sb-posix:wait)
  27                (format t "~&; Subprocess ~D exit status ~D~%"  pid status)
  28                (setq subprocess-list (delete pid subprocess-list)))
  29              (decf subprocess-count)))
  30       (do-stems-and-flags (stem flags)
  31         (unless (position :not-host flags)
  32           (when (>= subprocess-count max-jobs)
  33             (wait))
  34           (let ((pid (sb-posix:fork)))
  35             (when (zerop pid)
  36               (in-host-compilation-mode
  37                (lambda () (compile-stem stem flags :host-compile)))
  38               ;; FIXME: convey exit code based on COMPILE result.
  39               (sb-cold::exit-process 0))
  40             (push pid subprocess-list)
  41             (incf subprocess-count)
  42             ;; Do not wait for the compile to finish. Just load as source.
  43             (let ((source (merge-pathnames (stem-remap-target stem)
  44                                            (make-pathname :type "lisp"))))
  45               (let ((sb-ext:*evaluator-mode* :interpret))
  46                 (in-host-compilation-mode
  47                  (lambda ()
  48                    (load source :verbose t :print nil))))))))
  49       (loop (if (plusp subprocess-count) (wait) (return)))))
  50
  51   ;; We want to load compiled files, because that's what this function promises.
  52   ;; Reloading is tricky because constructors for interned ctypes will construct
  53   ;; new objects via their LOAD-TIME-VALUE forms, but globaldb already stored
  54   ;; some objects from the interpreted pre-load.
  55   ;; So wipe everything out that causes problems down the line.
  56   ;; (Or perhaps we could make their effects idempotent)
  57   (format t "~&; Parallel build: Clearing globaldb~%")
  58   (do-all-symbols (s)
  59     (when (get s :sb-xc-globaldb-info)
  60       (remf (symbol-plist s) :sb-xc-globaldb-info)))
  61   (fill (symbol-value 'sb!impl::*info-types*) nil)
  62   (clrhash (symbol-value 'sb!kernel::*forward-referenced-layouts*))
  63   (setf (symbol-value 'sb!kernel:*type-system-initialized*) nil)
  64   (makunbound 'sb!c::*backend-primitive-type-names*)
  65   (makunbound 'sb!c::*backend-primitive-type-aliases*)
  66
  67   (format t "~&; Parallel build: Reloading compilation artifacts~%")
  68   ;; Now it works to load fasls.
  69   (in-host-compilation-mode
  70    (lambda ()
  71      (handler-bind ((sb-kernel:redefinition-warning #'muffle-warning))
  72        (do-stems-and-flags (stem flags)
  73          (unless (position :not-host flags)
  74            (load (stem-object-path stem flags :host-compile)
  75                  :verbose t :print nil))))))
  76   (format t "~&; Parallel build: Fasl loading complete~%"))
  77
  78 ;;; Either load or compile-then-load the cross-compiler into the
  79 ;;; cross-compilation host Common Lisp.
  80 (defun load-or-cload-xcompiler (load-or-cload-stem)
  81   (declare (type function load-or-cload-stem))
  82   ;; Build a version of Python to run in the host Common Lisp, to be
  83   ;; used only in cross-compilation.
  84   ;;
  85   ;; Note that files which are marked :ASSEM, to cause them to be
  86   ;; processed with SB!C:ASSEMBLE-FILE when we're running under the
  87   ;; cross-compiler or the target lisp, are still processed here, just
  88   ;; with the ordinary Lisp compiler, and this is intentional, in
  89   ;; order to make the compiler aware of the definitions of assembly
  90   ;; routines.
  91   (if (and (make-host-1-parallelism)
  92            (eq load-or-cload-stem #'host-cload-stem))
  93       (funcall (intern "PARALLEL-MAKE-HOST-1" 'sb-cold)
  94                (make-host-1-parallelism))
  95       (do-stems-and-flags (stem flags)
  96         (unless (find :not-host flags)
  97           (funcall load-or-cload-stem stem flags)
  98           #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*))))
  99
 100   ;; If the cross-compilation host is SBCL itself, we can use the
 101   ;; PURIFY extension to freeze everything in place, reducing the
 102   ;; amount of work done on future GCs. In machines with limited
 103   ;; memory, this could help, by reducing the amount of memory which
 104   ;; needs to be juggled in a full GC. And it can hardly hurt, since
 105   ;; (in the ordinary build procedure anyway) essentially everything
 106   ;; which is reachable at this point will remain reachable for the
 107   ;; entire run.
 108   ;;
 109   ;; (Except that purifying actually slows down GENCGC). -- JES, 2006-05-30
 110   #+(and sbcl (not gencgc))
 111   (sb-ext:purify)
 112
 113   (values))
 114
 115 ;; Keep these in order by package, then symbol.
 116 (dolist (sym
 117          (append
 118           ;; CL, EXT, KERNEL
 119           '(allocate-instance
 120             compute-applicable-methods
 121             slot-makunbound
 122             make-load-form-saving-slots
 123             sb!ext:run-program
 124             sb!vm::map-allocated-objects
 125             sb!vm::map-objects-in-range
 126             sb!kernel::choose-code-component-order)
 127           ;; CLOS implementation
 128           '(sb!mop:class-finalized-p
 129             sb!mop:class-prototype
 130             sb!mop:class-slots
 131             sb!mop:eql-specializer-object
 132             sb!mop:finalize-inheritance
 133             sb!mop:generic-function-name
 134             (setf sb!mop:generic-function-name)
 135             sb!mop:slot-definition-allocation
 136             sb!mop:slot-definition-name
 137             sb!pcl::%force-cache-flushes
 138             sb!pcl::check-wrapper-validity
 139             sb!pcl::class-has-a-forward-referenced-superclass-p
 140             sb!pcl::class-wrapper
 141             sb!pcl::compute-gf-ftype
 142             sb!pcl::definition-source
 143             sb!pcl::ensure-accessor
 144             sb!pcl:ensure-class-finalized)
 145           ;; CLOS-based packages
 146           '(sb!gray:stream-clear-input
 147             sb!gray:stream-clear-output
 148             sb!gray:stream-file-position
 149             sb!gray:stream-finish-output
 150             sb!gray:stream-force-output
 151             sb!gray:stream-fresh-line
 152             sb!gray:stream-line-column
 153             sb!gray:stream-line-length
 154             sb!gray:stream-listen
 155             sb!gray:stream-peek-char
 156             sb!gray:stream-read-byte
 157             sb!gray:stream-read-char
 158             sb!gray:stream-read-char-no-hang
 159             sb!gray:stream-read-line
 160             sb!gray:stream-read-sequence
 161             sb!gray:stream-terpri
 162             sb!gray:stream-unread-char
 163             sb!gray:stream-write-byte
 164             sb!gray:stream-write-char
 165             sb!gray:stream-write-sequence
 166             sb!gray:stream-write-string
 167             sb!sequence:concatenate
 168             sb!sequence:copy-seq
 169             sb!sequence:count
 170             sb!sequence:count-if
 171             sb!sequence:count-if-not
 172             sb!sequence:delete
 173             sb!sequence:delete-duplicates
 174             sb!sequence:delete-if
 175             sb!sequence:delete-if-not
 176             (setf sb!sequence:elt)
 177             sb!sequence:elt
 178             sb!sequence:emptyp
 179             sb!sequence:fill
 180             sb!sequence:find
 181             sb!sequence:find-if
 182             sb!sequence:find-if-not
 183             (setf sb!sequence:iterator-element)
 184             sb!sequence:iterator-endp
 185             sb!sequence:iterator-step
 186             sb!sequence:length
 187             sb!sequence:make-sequence-iterator
 188             sb!sequence:make-sequence-like
 189             sb!sequence:map
 190             sb!sequence:merge
 191             sb!sequence:mismatch
 192             sb!sequence:nreverse
 193             sb!sequence:nsubstitute
 194             sb!sequence:nsubstitute-if
 195             sb!sequence:nsubstitute-if-not
 196             sb!sequence:position
 197             sb!sequence:position-if
 198             sb!sequence:position-if-not
 199             sb!sequence:reduce
 200             sb!sequence:remove
 201             sb!sequence:remove-duplicates
 202             sb!sequence:remove-if
 203             sb!sequence:remove-if-not
 204             sb!sequence:replace
 205             sb!sequence:reverse
 206             sb!sequence:search
 207             sb!sequence:sort
 208             sb!sequence:stable-sort
 209             sb!sequence:subseq
 210             sb!sequence:substitute
 211             sb!sequence:substitute-if
 212             sb!sequence:substitute-if-not)
 213           ;; Fast interpreter
 214           #!+sb-fasteval
 215           '(sb!interpreter:%fun-type
 216             sb!interpreter:env-policy
 217             sb!interpreter:eval-in-environment
 218             sb!interpreter:find-lexical-fun
 219             sb!interpreter:find-lexical-var
 220             sb!interpreter::flush-everything
 221             sb!interpreter::fun-lexically-notinline-p
 222             sb!interpreter:lexenv-from-env
 223             sb!interpreter::lexically-unlocked-symbol-p
 224             sb!interpreter:list-locals
 225             sb!interpreter:prepare-for-compile
 226             sb!interpreter::reconstruct-syntactic-closure-env)
 227           ;; Other
 228           '(sb!debug::find-interrupted-name-and-frame
 229             sb!impl::encapsulate-generic-function
 230             sb!impl::encapsulated-generic-function-p
 231             sb!impl::get-processes-status-changes
 232             sb!impl::step-form
 233             sb!impl::step-values
 234             sb!impl::stringify-package-designator
 235             sb!impl::stringify-string-designator
 236             sb!impl::stringify-string-designators
 237             sb!impl::unencapsulate-generic-function)))
 238   (setf (gethash sym *undefined-fun-whitelist*) t))