;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-COLD")

;;; ABCL has some trouble with our code. Consider this minimal example:
#|
(defstruct (args-type)
  (required nil :type list :read-only t))
(defstruct (fun-type (:include args-type)
  (:constructor %make-fun-type (required))))
(defstruct (fun-designator-type
            (:include fun-type)
            (:conc-name fun-type-)
            (:constructor make-fun-designator-type (required))))
(defun foo (x) (fun-type-required x))
|#
;;; Then (FUN-TYPE-REQUIRED (%MAKE-FUN-TYPE 'YAY)) => YAY
;;; but (FOO (%MAKE-FUN-TYPE '())) signals
;;;  #<THREAD "interpreter" {58AF2733}>: Debugger invoked on condition of type SIMPLE-TYPE-ERROR
;;;  The value #<FUN-TYPE {630252C7}> is not of type FUN-DESIGNATOR-TYPE.
;;; So apparently it clobbered the FUN-TYPE-REQUIRED accessor with the one from
;;; the defstruct of the descendant type due to use of the same :CONC-NAME.
;;; This is supposed to work. It only fails in compiled code.
;;;
;;; A bug was already reported as https://abcl.org/trac/ticket/231 on their tracker,
;;; however the comments erroneously claim that "clisp exhibits the same behaviour and the
;;; spec allows it (or at least, doesn't specify behaviour for it)." which is wrong as to
;;; the latter point if not also the former:
;;; (1) if CLISP exhibited that behavior, then it would not compile SBCL - though in
;;;     fairness that note is 6 years old; and
;;; (2) the spec absolutely does say something about it:
;;;     Whether or not the :conc-name option is explicitly supplied, the following rule
;;;     governs name conflicts of generated reader (or accessor) names: For any structure
;;;     type S1 having a reader function named R for a slot named X1 that is inherited by
;;;     another structure type S2 that would have a reader function with the same name R for
;;;     a slot named X2, no definition for R is generated by the definition of S2; instead,
;;;     the definition of R is inherited from the definition of S1. (In such a case,
;;;     if X1 and X2 are different slots, the implementation might signal a style warning.)
;;;
;;; Calling the accessors out-of-line works around the problem.
;;; These must go outside of any compiled file in order to affect ABCL's global defaults.
#+abcl
(declaim (notinline
          sb-kernel:fun-type-required
          sb-kernel:fun-type-optional
          sb-kernel:fun-type-rest
          sb-kernel:fun-type-keyp
          sb-kernel:fun-type-keywords
          sb-kernel:fun-type-allowp
          sb-kernel:fun-type-wild-args
          sb-kernel:fun-type-returns))

#+#.(cl:if (cl:find-package "HOST-SB-POSIX") '(and) '(or))
(defun parallel-make-host-1 (max-jobs)
  (let ((subprocess-count 0)
        (subprocess-list nil)
        stop)
    (flet ((wait ()
             (multiple-value-bind (pid status) (host-sb-posix:wait)
               (format t "~&; Subprocess ~D exit status ~D~%"  pid status)
               (unless (zerop status)
                 (setf stop t))
               (setq subprocess-list (delete pid subprocess-list)))
             (decf subprocess-count)))
      (host-sb-ext:disable-debugger)
      (unwind-protect
           (do-stems-and-flags (stem flags 1)
             (unless (position :not-host flags)
               (when (>= subprocess-count max-jobs)
                 (wait))
               (when stop
                 (return))
               (let ((pid (host-sb-posix:fork)))
                 (when (zerop pid)
                   (in-host-compilation-mode
                    (lambda () (compile-stem stem flags :host-compile)))
                   ;; FIXME: convey exit code based on COMPILE result.
                   (sb-cold::exit-process 0))
                 (push pid subprocess-list)
                 (incf subprocess-count)
                 ;; Do not wait for the compile to finish. Just load as source.
                 (let ((source (merge-pathnames (stem-remap-target stem)
                                                (make-pathname :type "lisp"))))
                   (let ((host-sb-ext:*evaluator-mode* :interpret))
                     (in-host-compilation-mode
                      (lambda ()
                        (load source :verbose t :print nil))))))))
        (loop (if (plusp subprocess-count) (wait) (return)))
        (when stop
          (sb-cold::exit-process 1)))))
  (format t "~&; Parallel build: Skipping fasl load~%"))

;;; Read the version file once and once only,
;;; or not at all if you've otherwise defined this.
(defvar *target-sbcl-version* (read-from-file "version.lisp-expr"))

#+ccl (declaim (ftype function warn-when-cl-snapshot-diff)) ; silly compiler

;;; Either load or compile-then-load the cross-compiler into the
;;; cross-compilation host Common Lisp.
(defun load-or-cload-xcompiler (load-or-cload-stem)
  (declare (type function load-or-cload-stem))
  ;; Build a version of Python to run in the host Common Lisp, to be
  ;; used only in cross-compilation.
  ;;
  ;; Note that files which are marked :ASSEM, to cause them to be
  ;; processed with SB-C:ASSEMBLE-FILE when we're running under the
  ;; cross-compiler or the target lisp, are still processed here, just
  ;; with the ordinary Lisp compiler, and this is intentional, in
  ;; order to make the compiler aware of the definitions of assembly
  ;; routines.
  (if (and (make-host-1-parallelism)
           (eq load-or-cload-stem #'host-cload-stem))
      (progn
        ;; FIXME: muffler not working in forked children?
        (setq *fail-on-warnings* nil)
        ;; Multiprocess build uses the in-memory math ops cache but not
        ;; the persistent cache file because we don't need each child
        ;; to be forced to read the file. Moreover, newly inserted values
        ;; can not propagate back to this process. And we can't read the
        ;; file up front because the reading function - though simple -
        ;; isn't defined until we compile src/code/cross-float.
        (funcall (intern "PARALLEL-MAKE-HOST-1" 'sb-cold)
                 (make-host-1-parallelism))
        ;; Flush the math ops cache. Why: loading fasls after parallel compile
        ;; causes some entries to be inserted, but without first prefilling
        ;; the cache from disk. Thus we have an incorrect opinion of whether the
        ;; in-memory view has strictly more values than on disk. This would cause
        ;; WITH-MATH-JOURNAL around loading of the "tests/*.before-xc.lisp" files
        ;; to behave wrong. It would initially observe the cache to have N (say 50)
        ;; entries instead of the much larger number of disk entries. Then after
        ;; the tests, it would observe a few more (say 70 total) entries, which,
        ;; because it is more, completely overwrite the disk cache that should have
        ;; had over 500 entries. So it would lose entries. CLRHASH fixes that.
        (clrhash *math-ops-memoization*))
      (with-math-journal
       (do-stems-and-flags (stem flags 1)
         (unless (find :not-host flags)
           ;; Enforce naming convention: target-* files are not for make-host-1
           (assert (not (search "code/target-" stem)))
           (funcall load-or-cload-stem stem flags)
           (when (member :sb-show sb-xc:*features*)
             (funcall 'warn-when-cl-snapshot-diff *cl-snapshot*))))))

  ;; Let's check that the type system, and various other things, are
  ;; reasonably sane. (It's easy to spend a long time wandering around
  ;; confused trying to debug cross-compilation if it isn't.)
  (funcall 'sb-c::check-vop-existence-correctness)
  (let ((*readtable* *xc-readtable*)
        (*load-verbose* t))
    (with-math-journal
       (load "tests/type.before-xc.lisp")
       (load "tests/info.before-xc.lisp")
       (load "tests/vm.before-xc.lisp")))

  (values))
