src/compiler/early-c.lisp

   1 ;;;; This file contains compiler code and compiler-related stuff which
   2 ;;;; can be built early on. Some of the stuff may be here because it's
   3 ;;;; needed early on, some other stuff (e.g. constants) just because
   4 ;;;; it might as well be done early so we don't have to think about
   5 ;;;; whether it's done early enough.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!C")
  17
  18 ;;; FIXME: Shouldn't SB!C::&MORE be in this list?
  19 (defconstant-eqx sb!xc:lambda-list-keywords
  20   '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
  21   #!+sb-doc
  22   #'equal
  23   "symbols which are magical in a lambda list")
  24 \f
  25 ;;;; cross-compiler-only versions of CL special variables, so that we
  26 ;;;; don't have weird interactions with the host compiler
  27
  28 (defvar sb!xc:*compile-file-pathname*)
  29 (defvar sb!xc:*compile-file-truename*)
  30 (defvar sb!xc:*compile-print*)
  31 (defvar sb!xc:*compile-verbose*)
  32 \f
  33 ;;;; miscellaneous types used both in the cross-compiler and on the target
  34
  35 ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
  36 ;;;; somewhere else, not "early-c", since they're after all not part
  37 ;;;; of the compiler.
  38
  39 ;;; the type of LAYOUT-DEPTHOID slot values
  40 (def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
  41
  42 ;;; a value for an optimization declaration
  43 (def!type sb!c::policy-quality () '(or (rational 0 3) null))
  44 \f
  45 ;;;; policy stuff
  46
  47 ;;; a map from optimization policy quality to corresponding POLICY
  48 ;;; slot name, used to automatically keep POLICY-related definitions
  49 ;;; in sync even if future maintenance changes POLICY slots
  50 (eval-when (:compile-toplevel :load-toplevel :execute)
  51   (defstruct (policy-quality-slot (:constructor %make-pqs (quality accessor)))
  52     ;; the name of the quality
  53     (quality (required-argument) :type symbol)
  54     ;; the name of the structure slot accessor
  55     (accessor (required-argument) :type symbol))
  56   (defparameter *policy-quality-slots*
  57     (list (%make-pqs 'speed   'policy-speed)
  58           (%make-pqs 'space   'policy-space)
  59           (%make-pqs 'safety  'policy-safety)
  60           (%make-pqs 'cspeed  'policy-cspeed)
  61           (%make-pqs 'brevity 'policy-brevity)
  62           (%make-pqs 'debug   'policy-debug)))
  63   (defun named-policy-quality-slot (name)
  64     (find name *policy-quality-slots* :key #'policy-quality-slot-quality)))
  65
  66 ;;; A POLICY object holds information about the compilation policy for
  67 ;;; a node. See the LEXENV definition for a description of how it is used.
  68 #.`(def!struct (policy
  69                 (:copier nil)) ; (but see DEFUN COPY-POLICY)
  70      ,@(mapcar (lambda (pqs)
  71                  `(,(policy-quality-slot-quality pqs) nil
  72                    :type policy-quality))
  73                *policy-quality-slots*))
  74
  75 ;;; an annoyingly hairy way of doing COPY-STRUCTURE on POLICY objects
  76 ;;;
  77 ;;; (We need this explicit, separate, hairy DEFUN only because we need
  78 ;;; to be able to copy POLICY objects in cold init toplevel forms,
  79 ;;; earlier than the default copier closure created by DEFSTRUCT
  80 ;;; toplevel forms would be available, and earlier than LAYOUT-INFO is
  81 ;;; initialized (which is a prerequisite for COPY-STRUCTURE to work).)
  82 #.`(defun copy-policy (policy)
  83      (make-policy
  84       ,@(mapcan (lambda (pqs)
  85                   `(,(keywordicate (policy-quality-slot-quality pqs))
  86                     (,(policy-quality-slot-accessor pqs) policy)))
  87                 *policy-quality-slots*)))
  88
  89 ;;; *DEFAULT-POLICY* holds the current global compiler policy
  90 ;;; information. Whenever the policy is changed, we copy the structure
  91 ;;; so that old uses will still get the old values.
  92 ;;; *DEFAULT-INTERFACE-POLICY* holds any values specified by an
  93 ;;; OPTIMIZE-INTERFACE declaration.
  94 (declaim (type policy *default-policy* *default-interface-policy*))
  95 (defvar *default-policy*)          ; initialized in cold init
  96 (defvar *default-interface-policy*) ; initialized in cold init
  97 \f
  98 ;;; possible values for the INLINE-ness of a function.
  99 (deftype inlinep ()
 100   '(member :inline :maybe-inline :notinline nil))
 101 (defparameter *inlinep-translations*
 102   '((inline . :inline)
 103     (notinline . :notinline)
 104     (maybe-inline . :maybe-inline)))
 105
 106 ;;; The lexical environment we are currently converting in.
 107 (defvar *lexenv*)
 108 (declaim (type lexenv *lexenv*))
 109
 110 ;;; *FREE-VARIABLES* translates from the names of variables referenced
 111 ;;; globally to the LEAF structures for them. *FREE-FUNCTIONS* is like
 112 ;;; *FREE-VARIABLES*, only it deals with function names.
 113 (defvar *free-variables*)
 114 (defvar *free-functions*)
 115 (declaim (hash-table *free-variables* *free-functions*))
 116
 117 ;;; We use the same Constant structure to represent all equal anonymous
 118 ;;; constants. This hashtable translates from constants to the Leafs that
 119 ;;; represent them.
 120 (defvar *constants*)
 121 (declaim (hash-table *constants*))
 122
 123 ;;; miscellaneous forward declarations
 124 (defvar *code-segment*)
 125 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
 126 (defvar *component-being-compiled*)
 127 (defvar *compiler-error-context*)
 128 (defvar *compiler-error-count*)
 129 (defvar *compiler-warning-count*)
 130 (defvar *compiler-style-warning-count*)
 131 (defvar *compiler-note-count*)
 132 (defvar *converting-for-interpreter*)
 133 (defvar *count-vop-usages*)
 134 (defvar *current-path*)
 135 (defvar *current-component*)
 136 (defvar *default-policy*)
 137 (defvar *default-interface-policy*)
 138 (defvar *dynamic-counts-tn*)
 139 (defvar *elsewhere*)
 140 (defvar *event-info*)
 141 (defvar *event-note-threshold*)
 142 (defvar *failure-p*)
 143 (defvar *fixups*)
 144 (defvar *in-pack*)
 145 (defvar *info-environment*)
 146 (defvar *lexenv*)
 147 (defvar *source-info*)
 148 (defvar *trace-table*)
 149 (defvar *undefined-warnings*)
 150 (defvar *warnings-p*)
 151 \f
 152 ;;;; miscellaneous utilities
 153
 154 ;;; Delete any undefined warnings for NAME and KIND. This is for the
 155 ;;; benefit of the compiler, but it's sometimes called from stuff like
 156 ;;; type-defining code which isn't logically part of the compiler.
 157 (declaim (ftype (function ((or symbol cons) keyword) (values))
 158                 note-name-defined))
 159 (defun note-name-defined (name kind)
 160   ;; We do this BOUNDP check because this function can be called when
 161   ;; not in a compilation unit (as when loading top-level forms).
 162   (when (boundp '*undefined-warnings*)
 163     (setq *undefined-warnings*
 164           (delete-if (lambda (x)
 165                        (and (equal (undefined-warning-name x) name)
 166                             (eq (undefined-warning-kind x) kind)))
 167                      *undefined-warnings*)))
 168   (values))
 169
 170 ;;; to be called when a variable is lexically bound
 171 (declaim (ftype (function (symbol) (values)) note-lexical-binding))
 172 (defun note-lexical-binding (symbol)
 173   (let ((name (symbol-name symbol)))
 174     ;; This check is intended to protect us from getting silently
 175     ;; burned when we define
 176     ;;   foo.lisp:
 177     ;;     (DEFVAR *FOO* -3)
 178     ;;     (DEFUN FOO (X) (+ X *FOO*))
 179     ;;   bar.lisp:
 180     ;;     (DEFUN BAR (X)
 181     ;;       (LET ((*FOO* X))
 182     ;;         (FOO 14)))
 183     ;; and then we happen to compile bar.lisp before foo.lisp.
 184     (when (and (char= #\* (aref name 0))
 185                (char= #\* (aref name (1- (length name)))))
 186       ;; FIXME: should be COMPILER-STYLE-WARNING?
 187       (style-warn "using the lexical binding of the symbol ~S, not the~@
 188 dynamic binding, even though the symbol name follows the usual naming~@
 189 convention (names like *FOO*) for special variables" symbol)))
 190   (values))