;;; Set up the cross-compiler.
(setf *print-level* 5 *print-length* 5)
(load "src/cold/shared.lisp")
(in-package "SB-COLD")
;;; FIXME: these prefixes look like non-pathnamy ways of defining a
;;; relative pathname.  Investigate whether they can be made relative
;;; pathnames.
(setf *host-obj-prefix* "obj/from-host/"
      *target-obj-prefix* "obj/from-xc/")
(load "src/cold/set-up-cold-packages.lisp")
(load "src/cold/defun-load-or-cload-xcompiler.lisp")
(load-or-cload-xcompiler #'host-load-stem)

;; Supress function/macro redefinition warnings under clisp.
#+clisp (setf custom:*suppress-check-redefinition* t)

;; Avoid natively compiling new code under ecl
#+ecl (ext:install-bytecodes-compiler)

;;; Run the cross-compiler to produce cold fasl files.
(setq sb-c::*track-full-called-fnames* :minimal) ; Change this as desired
(setq sb-c::*static-vop-usage-counts* (make-hash-table))
(let (fail
      variables
      functions
      types
      warnp
      style-warnp)
  ;; Even the host may get STYLE-WARNINGS from e.g. cross-compiling
  ;; macro definitions. FIXME: This is duplicate code from make-host-1
  (handler-bind ((style-warning
                   (lambda (c)
                     (signal c)
                     (setq style-warnp 'style-warning)))
                 (simple-warning
                   (lambda (c)
                     (declare (ignore c))
                     (setq warnp 'warning))))
    (sb-xc:with-compilation-unit ()
      (load "src/cold/compile-cold-sbcl.lisp")
      ;; Enforce absence of unexpected forward-references to warm loaded code.
      ;; Looking into a hidden detail of this compiler seems fair game.
      (when sb-c::*undefined-warnings*
        (setf fail t)
        (dolist (warning sb-c::*undefined-warnings*)
          (case (sb-c::undefined-warning-kind warning)
            (:variable (setf variables t))
            (:type (setf types t))
            (:function (setf functions t)))))))
  ;; Exit the compilation unit so that the summary is printed. Then complain.
  (when fail
    (cerror "Proceed anyway"
            "Undefined ~:[~;variables~] ~:[~;types~]~
             ~:[~;functions (incomplete SB-COLD::*UNDEFINED-FUN-ALLOWLIST*?)~]"
            variables types functions))
  (when (and (or warnp style-warnp) *fail-on-warnings* (not (target-featurep :win32)))
    (cerror "Proceed anyway"
            "make-host-2 stopped due to unexpected ~A raised from the host." (or warnp style-warnp))))

#-clisp ; DO-ALL-SYMBOLS seems to kill CLISP at random
(do-all-symbols (s)
  (when (and (sb-int:info :function :inlinep s)
             (eq (sb-int:info :function :where-from s) :assumed))
      (error "INLINE declaration for an undefined function: ~S?" s)))

(with-open-file (output "output/cold-vop-usage.txt"
                        :direction :output :if-exists :supersede)
  (sb-int:dohash ((name vop) sb-c::*backend-parsed-vops*)
    (declare (ignore vop))
    (format output "~7d ~s~%"
            (gethash name sb-c::*static-vop-usage-counts* 0)
            ;; change SB-XC symbols back to their normal counterpart
            (if (string= (cl:package-name (cl:symbol-package name)) "SB-XC")
                (find-symbol (string name) "COMMON-LISP")
                name))))

;; After cross-compiling, show me a list of types that checkgen
;; would have liked to use primitive traps for but couldn't.
#+nil
(let ((l (sb-impl::%hash-table-alist sb-c::*checkgen-used-types*)))
  (format t "~&Types needed by checkgen: ('+' = has internal error number)~%")
  (setq l (sort l #'> :key #'cadr))
  (loop for (type-spec . (count . interr-p)) in l
        do (format t "~:[ ~;+~] ~5D ~S~%" interr-p count type-spec))
  (format t "~&Error numbers not used by checkgen:~%")
  (loop for (spec symbol) across sb-c:+backend-internal-errors+
        when (and (not (stringp spec))
                  (not (gethash spec sb-c::*checkgen-used-types*)))
        do (format t "       ~S~%" spec)))

;; Print some information about how well the type operator caches performed
(when sb-impl::*profile-hash-cache*
  (sb-impl::show-hash-cache-statistics))
#|
Sample output
-------------
     Seek       Hit      (%)    Evict      (%) Size    full
 23698219  18382256 ( 77.6%)  5313915 ( 22.4%) 2048  100.0% TYPE=-CACHE
 23528751  23416735 ( 99.5%)    46242 (  0.2%) 1024   20.1% VALUES-SPECIFIER-TYPE-CACHE
 16755212  13072420 ( 78.0%)  3681768 ( 22.0%) 1024  100.0% CSUBTYPEP-CACHE
  9913114   8374965 ( 84.5%)  1537893 ( 15.5%)  256  100.0% MAKE-VALUES-TYPE-CACHED-CACHE
  7718160   4702069 ( 60.9%)  3675019 ( 47.6%)  512  100.0% TYPE-INTERSECTION2-CACHE
  5184706   1626512 ( 31.4%)  3557973 ( 68.6%)  256   86.3% %TYPE-INTERSECTION-CACHE
  5156044   3986450 ( 77.3%)  1169338 ( 22.7%)  256  100.0% VALUES-SUBTYPEP-CACHE
  4550163   2969409 ( 65.3%)  1580498 ( 34.7%)  256  100.0% VALUES-TYPE-INTERSECTION-CACHE
  3544211   2607658 ( 73.6%)   936300 ( 26.4%)  256   98.8% %TYPE-UNION-CACHE
  2545070   2110741 ( 82.9%)   433817 ( 17.0%)  512  100.0% PRIMITIVE-TYPE-AUX-CACHE
  2164841   1112785 ( 51.4%)  1706097 ( 78.8%)  256  100.0% TYPE-UNION2-CACHE
  1568022   1467575 ( 93.6%)   100191 (  6.4%)  256  100.0% TYPE-SINGLETON-P-CACHE
   779941    703208 ( 90.2%)    76477 (  9.8%)  256  100.0% %COERCE-TO-VALUES-CACHE
   618605    448427 ( 72.5%)   169922 ( 27.5%)  256  100.0% VALUES-TYPE-UNION-CACHE
   145805     29403 ( 20.2%)   116206 ( 79.7%)  256   76.6% %%MAKE-UNION-TYPE-CACHED-CACHE
   118634     76203 ( 64.2%)    42188 ( 35.6%)  256   94.9% %%MAKE-ARRAY-TYPE-CACHED-CACHE
    12319     12167 ( 98.8%)       47 (  0.4%)  128   82.0% WEAKEN-TYPE-CACHE
    10416      9492 ( 91.1%)      668 (  6.4%)  256  100.0% TYPE-NEGATION-CACHE
|#

;;; Let's check that the type system was reasonably sane. (It's easy
;;; to spend a long time wandering around confused trying to debug
;;; cold init if it wasn't.)
(load "tests/type.after-xc.lisp")

;;; If you're experimenting with the system under a cross-compilation
;;; host which supports CMU-CL-style SAVE-LISP, this can be a good
;;; time to run it. The resulting core isn't used in the normal build,
;;; but can be handy for experimenting with the system. (See slam.sh
;;; for an example.)
;;; FIXME: can we just always do this for supported hosts, and remove the choice?
(cond #+sbcl (t (host-sb-ext:save-lisp-and-die "output/after-xc.core"))
      ((member :sb-after-xc-core sb-xc:*features*)
       #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
       #+openmcl (ccl::save-application "output/after-xc.core")
       #+clisp (ext:saveinitmem "output/after-xc.core")))
