make-host-2.lisp

   1 ;;; Set up the cross-compiler.
   2 (setf *print-level* 5 *print-length* 5)
   3 (load "src/cold/shared.lisp")
   4 (in-package "SB-COLD")
   5
   6 ;;; FIXME: these prefixes look like non-pathnamy ways of defining a
   7 ;;; relative pathname.  Investigate whether they can be made relative
   8 ;;; pathnames.
   9 (setf *host-obj-prefix* "obj/from-host/"
  10       *target-obj-prefix* "obj/from-xc/")
  11 (load "src/cold/set-up-cold-packages.lisp")
  12 (load "src/cold/defun-load-or-cload-xcompiler.lisp")
  13 (load-or-cload-xcompiler #'host-load-stem)
  14 ;;; Set up the perfect hash generator for the target's value of N-FIXNUM-BITS.
  15 (preload-perfect-hash-generator (perfect-hash-generator-journal :input))
  16
  17 ;; Supress function/macro redefinition warnings under clisp.
  18 #+clisp (setf custom:*suppress-check-redefinition* t)
  19
  20 ;; Avoid natively compiling new code under ecl
  21 #+ecl (ext:install-bytecodes-compiler)
  22
  23 (defun copy-file-from-file (new old)
  24   (with-open-file (output new :direction :output :if-exists :supersede
  25                           :if-does-not-exist :create)
  26     (with-open-file (input old)
  27       (loop (let ((line (read-line input nil)))
  28               (if line (write-line line output) (return new)))))))
  29
  30 ;;; Run the cross-compiler to produce cold fasl files.
  31 (setq sb-c::*track-full-called-fnames* :minimal) ; Change this as desired
  32 (setq sb-c::*static-vop-usage-counts* (make-hash-table))
  33 (let (fail
  34       variables
  35       functions
  36       types
  37       warnp
  38       style-warnp)
  39   ;; Even the host may get STYLE-WARNINGS from e.g. cross-compiling
  40   ;; macro definitions. FIXME: This is duplicate code from make-host-1
  41   (handler-bind ((style-warning
  42                    (lambda (c)
  43                      (signal c)
  44                      (setq style-warnp 'style-warning)))
  45                  (simple-warning
  46                    (lambda (c)
  47                      (declare (ignore c))
  48                      (setq warnp 'warning))))
  49     (sb-xc:with-compilation-unit ()
  50       (load "src/cold/compile-cold-sbcl.lisp")
  51       (let ((cache (math-journal-pathname :output)))
  52         (when (probe-file cache)
  53           (copy-file-from-file "output/xfloat-math.lisp-expr" cache)
  54           (format t "~&Math journal: replaced from ~S~%" cache)))
  55       ;; Enforce absence of unexpected forward-references to warm loaded code.
  56       ;; Looking into a hidden detail of this compiler seems fair game.
  57       (when sb-c::*undefined-warnings*
  58         (setf fail t)
  59         (dolist (warning sb-c::*undefined-warnings*)
  60           (case (sb-c::undefined-warning-kind warning)
  61             (:variable (setf variables t))
  62             (:type (setf types t))
  63             (:function (setf functions t)))))))
  64   ;; Exit the compilation unit so that the summary is printed. Then complain.
  65   (when fail
  66     (cerror "Proceed anyway"
  67             "Undefined ~:[~;variables~] ~:[~;types~]~
  68              ~:[~;functions (incomplete SB-COLD::*UNDEFINED-FUN-ALLOWLIST*?)~]"
  69             variables types functions))
  70   (when (and (or warnp style-warnp) *fail-on-warnings* (not (target-featurep :win32)))
  71     (cerror "Proceed anyway"
  72             "make-host-2 stopped due to unexpected ~A raised from the host." (or warnp style-warnp))))
  73
  74 #-clisp ; DO-ALL-SYMBOLS seems to kill CLISP at random
  75 (do-all-symbols (s)
  76   (when (and (sb-int:info :function :inlinep s)
  77              (eq (sb-int:info :function :where-from s) :assumed))
  78       (error "INLINE declaration for an undefined function: ~S?" s)))
  79
  80 (with-open-file (output "output/cold-vop-usage.txt"
  81                         :direction :output :if-exists :supersede)
  82   (sb-int:dohash ((name vop) sb-c::*backend-parsed-vops*)
  83     (declare (ignore vop))
  84     (format output "~7d ~s~%"
  85             (gethash name sb-c::*static-vop-usage-counts* 0)
  86             ;; change SB-XC symbols back to their normal counterpart
  87             (if (string= (cl:package-name (cl:symbol-package name)) "SB-XC")
  88                 (find-symbol (string name) "COMMON-LISP")
  89                 name))))
  90
  91 ;; After cross-compiling, show me a list of types that checkgen
  92 ;; would have liked to use primitive traps for but couldn't.
  93 #+nil
  94 (let ((l (sb-impl::%hash-table-alist sb-c::*checkgen-used-types*)))
  95   (format t "~&Types needed by checkgen: ('+' = has internal error number)~%")
  96   (setq l (sort l #'> :key #'cadr))
  97   (loop for (type-spec . (count . interr-p)) in l
  98         do (format t "~:[ ~;+~] ~5D ~S~%" interr-p count type-spec))
  99   (format t "~&Error numbers not used by checkgen:~%")
 100   (loop for (spec symbol) across sb-c:+backend-internal-errors+
 101         when (and (not (stringp spec))
 102                   (not (gethash spec sb-c::*checkgen-used-types*)))
 103         do (format t "       ~S~%" spec)))
 104
 105 ;; Print some information about how well the type operator caches performed
 106 (when sb-impl::*profile-hash-cache*
 107   (sb-impl::show-hash-cache-statistics))
 108 #|
 109 Sample output
 110 -------------
 111      Seek       Hit      (%)    Evict      (%) Size    full
 112  23698219  18382256 ( 77.6%)  5313915 ( 22.4%) 2048  100.0% TYPE=-CACHE
 113  23528751  23416735 ( 99.5%)    46242 (  0.2%) 1024   20.1% VALUES-SPECIFIER-TYPE-CACHE
 114  16755212  13072420 ( 78.0%)  3681768 ( 22.0%) 1024  100.0% CSUBTYPEP-CACHE
 115   9913114   8374965 ( 84.5%)  1537893 ( 15.5%)  256  100.0% MAKE-VALUES-TYPE-CACHED-CACHE
 116   7718160   4702069 ( 60.9%)  3675019 ( 47.6%)  512  100.0% TYPE-INTERSECTION2-CACHE
 117   5184706   1626512 ( 31.4%)  3557973 ( 68.6%)  256   86.3% %TYPE-INTERSECTION-CACHE
 118   5156044   3986450 ( 77.3%)  1169338 ( 22.7%)  256  100.0% VALUES-SUBTYPEP-CACHE
 119   4550163   2969409 ( 65.3%)  1580498 ( 34.7%)  256  100.0% VALUES-TYPE-INTERSECTION-CACHE
 120   3544211   2607658 ( 73.6%)   936300 ( 26.4%)  256   98.8% %TYPE-UNION-CACHE
 121   2545070   2110741 ( 82.9%)   433817 ( 17.0%)  512  100.0% PRIMITIVE-TYPE-AUX-CACHE
 122   2164841   1112785 ( 51.4%)  1706097 ( 78.8%)  256  100.0% TYPE-UNION2-CACHE
 123   1568022   1467575 ( 93.6%)   100191 (  6.4%)  256  100.0% TYPE-SINGLETON-P-CACHE
 124    779941    703208 ( 90.2%)    76477 (  9.8%)  256  100.0% %COERCE-TO-VALUES-CACHE
 125    618605    448427 ( 72.5%)   169922 ( 27.5%)  256  100.0% VALUES-TYPE-UNION-CACHE
 126    145805     29403 ( 20.2%)   116206 ( 79.7%)  256   76.6% %%MAKE-UNION-TYPE-CACHED-CACHE
 127    118634     76203 ( 64.2%)    42188 ( 35.6%)  256   94.9% %%MAKE-ARRAY-TYPE-CACHED-CACHE
 128     12319     12167 ( 98.8%)       47 (  0.4%)  128   82.0% WEAKEN-TYPE-CACHE
 129     10416      9492 ( 91.1%)      668 (  6.4%)  256  100.0% TYPE-NEGATION-CACHE
 130 |#
 131
 132 ;;; Let's check that the type system was reasonably sane. (It's easy
 133 ;;; to spend a long time wandering around confused trying to debug
 134 ;;; cold init if it wasn't.)
 135 (load "tests/type.after-xc.lisp")
 136
 137 ;;; If you're experimenting with the system under a cross-compilation
 138 ;;; host which supports CMU-CL-style SAVE-LISP, this can be a good
 139 ;;; time to run it. The resulting core isn't used in the normal build,
 140 ;;; but can be handy for experimenting with the system. (See slam.sh
 141 ;;; for an example.)
 142 ;;; FIXME: can we just always do this for supported hosts, and remove the choice?
 143 (cond #+sbcl (t (host-sb-ext:save-lisp-and-die "output/after-xc.core"))
 144       ((member :sb-after-xc-core sb-xc:*features*)
 145        #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
 146        #+openmcl (ccl::save-application "output/after-xc.core")
 147        #+clisp (ext:saveinitmem "output/after-xc.core")))