src/pcl/pre-warm.lisp

   1 ;;;; In support of PCL we compile some things into the cold image.
   2 ;;;; Not only does this simplify the PCL bootstrap ever so slightly,
   3 ;;;; it is nice to be able to test for types SB!PCL::%METHOD-FUNCTION
   4 ;;;; and CLASS (neither of which will have any instances too early).
   5
   6 ;;;; This software is part of the SBCL system. See the README file for more
   7 ;;;; information.
   8
   9 ;;;; This software is derived from software originally released by Xerox
  10 ;;;; Corporation. Copyright and release statements follow. Later modifications
  11 ;;;; to the software are in the public domain and are provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  13 ;;;; information.
  14
  15 ;;;; copyright information from original PCL sources:
  16 ;;;;
  17 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  18 ;;;; All rights reserved.
  19 ;;;;
  20 ;;;; Use and copying of this software and preparation of derivative works based
  21 ;;;; upon this software are permitted. Any distribution of this software or
  22 ;;;; derivative works must comply with all applicable United States export
  23 ;;;; control laws.
  24 ;;;;
  25 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  26 ;;;; warranty about the software, its performance or its conformity to any
  27 ;;;; specification.
  28
  29 (in-package "SB!PCL")
  30
  31
  32 ;;; method function stuff.
  33 ;;;
  34 ;;; PCL historically included a so-called method-fast-function, which
  35 ;;; is essentially a method function but with (a) a precomputed
  36 ;;; continuation for CALL-NEXT-METHOD and (b) a permutation vector for
  37 ;;; slot access.  [ FIXME: see if we can understand these two
  38 ;;; optimizations before commit. ]  However, the presence of the
  39 ;;; fast-function meant that we violated AMOP and the effect of the
  40 ;;; :FUNCTION initarg, and furthermore got to potentially confusing
  41 ;;; situations where the function and the fast-function got out of
  42 ;;; sync, so that calling (method-function method) with the defined
  43 ;;; protocol would do different things from (call-method method) in
  44 ;;; method combination.
  45 ;;;
  46 ;;; So we define this internal method function structure, which we use
  47 ;;; when we create a method function ourselves.  This means that we
  48 ;;; can hang the various bits of information that we want off the
  49 ;;; method function itself, and also that if a user overrides method
  50 ;;; function creation there is no danger of having the system get
  51 ;;; confused.
  52 #-sb-xc-host ; host doesn't need
  53 (!defstruct-with-alternate-metaclass %method-function
  54   :slot-names (fast-function name)
  55   :boa-constructor %make-method-function
  56   :superclass-name function
  57   :metaclass-name static-classoid
  58   :metaclass-constructor make-static-classoid
  59   :dd-type funcallable-structure)
  60
  61 ;;; Set up fake standard-classes.
  62 ;;; This is enough to fool the compiler into optimizing TYPEP into
  63 ;;; %INSTANCE-TYPEP.
  64 ;;; I'll bet that at least half of these we don't need at all.
  65 (defparameter *!early-class-predicates*
  66   '((specializer specializerp)
  67     (standard-specializer standard-specializer-p)
  68     (exact-class-specializer exact-class-specializer-p)
  69     (class-eq-specializer class-eq-specializer-p)
  70     (eql-specializer eql-specializer-p)
  71     (class classp)
  72     (slot-class slot-class-p)
  73     (std-class std-class-p)
  74     (standard-class standard-class-p)
  75     (funcallable-standard-class funcallable-standard-class-p)
  76     (condition-class condition-class-p)
  77     (structure-class structure-class-p)
  78     (forward-referenced-class forward-referenced-class-p)
  79     (method method-p) ; shouldn't this be spelled METHODP? (like CLASSP)
  80     (standard-method standard-method-p)
  81     (accessor-method accessor-method-p)
  82     (standard-accessor-method standard-accessor-method-p)
  83     (standard-reader-method standard-reader-method-p)
  84     (standard-writer-method standard-writer-method-p)
  85     (standard-boundp-method standard-boundp-method-p)
  86     (global-reader-method global-reader-method-p)
  87     (global-writer-method global-writer-method-p)
  88     (global-boundp-method global-boundp-method-p)
  89     (generic-function generic-function-p)
  90     (standard-generic-function standard-generic-function-p)
  91     (method-combination method-combination-p)
  92     (long-method-combination long-method-combination-p)
  93     (short-method-combination short-method-combination-p)))
  94
  95 #+sb-xc-host
  96 (flet ((create-fake-classoid (name fun-p)
  97          (let* ((classoid (make-standard-classoid :name name))
  98                 (cell (sb!kernel::make-classoid-cell name classoid))
  99                 (layout
 100                  (make-layout
 101                   :classoid classoid
 102                   :inherits (map 'vector #'find-layout
 103                                  (cons t (if fun-p '(function))))
 104                   :length 0 ; don't care
 105                   :depthoid -1
 106                   :invalid nil)))
 107            (setf (classoid-layout classoid) layout
 108                  (info :type :classoid-cell name) cell
 109                  (info :type :kind name) :instance))))
 110   ;; Because we don't wire into %INSTANCE-TYPEP any assumptions about
 111   ;; the superclass/subclass relationships, these can all trivially be faked.
 112   (dolist (x *!early-class-predicates*)
 113     (let ((name (car x)))
 114       ;; GENERIC-FUNCTION and STANDARD-GENERIC-FUNCTION must contain
 115       ;; FUNCTION in their layouts so that their type predicates
 116       ;; optimize into FUNCALLABLE-INSTANCE-P (followed by a layout check),
 117       ;; rather than testing both that and INSTANCEP.
 118       (create-fake-classoid name
 119                             (memq name '(standard-generic-function
 120                                          generic-function))))))
 121
 122 ;;; BIG FAT WARNING: These predicates can't in general be called prior to the
 123 ;;; definition of the class which they test. However in carefully controlled
 124 ;;; circumstances they can be called when their class under test is not defined.
 125 ;;; The exact requirement is that the lowtag test must fail.
 126 ;;; So for example you can call GENERIC-FUNCTION-P on a HASH-TABLE,
 127 ;;; and CLASSP on a STRING, but you can't call CLASSP on anything that is either
 128 ;;; a FUNCALLABLE-INSTANCE or INSTANCE.
 129 ;;; With that caveat in mind, these are nifty things to have ASAP.
 130 #-sb-xc-host
 131 (macrolet ((define-class-predicates ()
 132              `(progn
 133                 ,@(mapcar (lambda (x)
 134                            (destructuring-bind (class-name predicate) x
 135                              `(defun ,predicate (x) (typep x ',class-name))))
 136                          *!early-class-predicates*))))
 137   (define-class-predicates))