src/code/cold-init-helper-macros.lisp

   1 ;;;; This file contains machinery for collecting forms that, in the
   2 ;;;; target Lisp, must happen before top level forms are run. The
   3 ;;;; forms are stuffed into named functions which will be explicitly
   4 ;;;; called in the appropriate order by !COLD-INIT.
   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!KERNEL")
  16 ;;; FIXME: Perhaps this belongs in the %SYS package like some other
  17 ;;; cold load stuff.
  18
  19 (eval-when (:compile-toplevel :load-toplevel :execute)
  20   (defvar *!cold-init-forms*))
  21
  22 (defmacro !begin-collecting-cold-init-forms ()
  23   #+sb-xc '(eval-when (:compile-toplevel :execute)
  24              (when (boundp '*!cold-init-forms*)
  25                (warn "discarding old *!COLD-INIT-FORMS* value"))
  26              (setf *!cold-init-forms* nil))
  27   #-sb-xc nil)
  28
  29 ;;; Note: Unlike the analogous COLD-INIT macro in CMU CL, this macro
  30 ;;; makes no attempt to simulate a top level situation by treating
  31 ;;; EVAL-WHEN forms specially.
  32 (defmacro !cold-init-forms (&rest forms)
  33   ;; In the target Lisp, stuff the forms into a named function which
  34   ;; will presumably be executed at the appropriate stage of cold load
  35   ;; (i.e. basically as soon as possible).
  36   #+sb-xc (progn
  37             (setf *!cold-init-forms*
  38                   (nconc *!cold-init-forms* (copy-list forms)))
  39             nil)
  40   ;; In the cross-compilation host Lisp, cold load is not a
  41   ;; meaningful concept. Just execute the forms at load time.
  42   #-sb-xc `(progn ,@forms))
  43
  44 (defmacro !defun-from-collected-cold-init-forms (name)
  45   #+sb-xc `(progn
  46              (defun ,name ()
  47                ,@*!cold-init-forms*
  48                (values))
  49              (eval-when (:compile-toplevel :execute)
  50                (makunbound '*!cold-init-forms*)))
  51   #-sb-xc (declare (ignore name)))
  52
  53 ;;; !DEFGLOBAL, !DEFPARAMETER and !DEFVAR are named by analogy
  54 ;;; with !COLD-INIT-FORMS and (not DEF!FOO) because they are
  55 ;;; basically additional cold-init-helpers to avoid the tedious sequence:
  56 ;;;    (!begin-collecting-cold-init-forms)
  57 ;;;    (defvar *foo*)
  58 ;;;    (!cold-init-forms (setq *foo* nil))
  59 ;;;    (!defun-from-cold-init-forms !some-cold-init-fun)
  60 ;;; or the less respectable (defvar *foo*) and a random SETQ in !COLD-INIT.
  61 ;;; Each is like its namesake, but also arranges so that genesis knows
  62 ;;; the initialization form, on which it calls EVAL and dumps as a constant
  63 ;;; when writing out the cold core image.
  64 (macrolet ((def (wrapper real-name)
  65              `(defmacro ,wrapper (sym value &optional (doc nil doc-p))
  66                 `(progn (,',real-name ,sym ,value ,@(if doc-p (list doc)))
  67                         #-sb-xc-host (sb!fasl::setq-no-questions-asked ,sym ,value)))))
  68   (def !defglobal defglobal)
  69   (def !defparameter defparameter)
  70   (def !defvar defvar))
  71
  72 (defmacro !set-load-form-method (class-name usable-by &optional method)
  73   ;; If USABLE-BY is:
  74   ;;  :host   - the host compiler can execute this M-L-F method
  75   ;;  :xc     - the cross-compiler can execute this M-L-F method
  76   ;;  :target - the target compiler can execute this M-L-F method
  77   (assert (and usable-by
  78                (every (lambda (x) (member x '(:host :xc :target)))
  79                       usable-by)))
  80   (multiple-value-bind (host-expr target-expr)
  81       (case method
  82         ((nil) ; default
  83          (values '(cl:make-load-form-saving-slots obj :environment env)
  84                  '(sb!xc:make-load-form-saving-slots obj :environment env)))
  85         (:ignore-it
  86          (values '(bug "Can't :ignore-it for host") :ignore-it))
  87         (t
  88          (assert (not (member :host usable-by)))
  89          (values nil `(funcall ,method obj env))))
  90     `(progn
  91        ,@(when (or #+sb-xc-host (member :host usable-by))
  92            `((defmethod make-load-form ((obj ,class-name) &optional env)
  93                ,host-expr)))
  94        ,@(when (or #+sb-xc-host (member :xc usable-by))
  95            ;; Use the host's CLOS implementation to select the target's method.
  96            `((defmethod sb!xc:make-load-form ((obj ,class-name) &optional env)
  97                (declare (ignorable obj env))
  98                ,target-expr)))
  99        ,@(when (or #-sb-xc-host (member :target usable-by))
 100            ;; Use the target's CLOS implementation
 101            `((defmethod make-load-form ((obj ,class-name) &optional env)
 102                (declare (ignorable obj env))
 103                ,target-expr))))))
 104
 105 ;;; Define a variable that is initialized in create_thread_struct() before any
 106 ;;; Lisp code can execute. In particular, *RESTART-CLUSTERS* and *HANDLER-CLUSTERS*
 107 ;;; should have a value before anything else happens.
 108 ;;; While thread-local vars are generally useful, this is not the implementation
 109 ;;; that would exist in the target system, if exposed more generally.
 110 ;;; (Among the issues is the very restricted initialization form)
 111 (defmacro !define-thread-local (name initform &optional docstring)
 112   (check-type initform symbol)
 113   #!-sb-thread `(!defvar ,name ,initform ,docstring)
 114   #!+sb-thread `(progn
 115                   #-sb-xc-host (!%define-thread-local ',name ',initform)
 116                   (defvar ,name ,initform ,docstring)))
 117
 118 (defvar *!thread-initial-bindings* nil)
 119 #+sb-xc-host
 120 (setf (get '!%define-thread-local :sb-cold-funcall-handler/for-effect)
 121       (lambda (name initsym)
 122         (push `(,name . ,initsym) *!thread-initial-bindings*)))
 123 #-sb-xc-host
 124 (defun !%define-thread-local (dummy1 dummy2) ; to avoid warning
 125   (declare (ignore dummy1 dummy2)))
 126
 127 ;;; FIXME: Consider renaming this file asap.lisp,
 128 ;;; and the renaming the various things
 129 ;;;   *ASAP-FORMS* or *REVERSED-ASAP-FORMS*
 130 ;;;   WITH-ASAP-FORMS
 131 ;;;   ASAP or EVAL-WHEN-COLD-LOAD
 132 ;;;   DEFUN-FROM-ASAP-FORMS
 133 ;;; If so, add a comment explaining that ASAP is colloquial English for "as
 134 ;;; soon as possible", and has nothing to do with "system area pointer".