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 ;;; ANSI limits on compilation
  19 (defconstant sb!xc:call-arguments-limit sb!xc:most-positive-fixnum
  20   "The exclusive upper bound on the number of arguments which may be passed
  21   to a function, including &REST args.")
  22 (defconstant sb!xc:lambda-parameters-limit sb!xc:most-positive-fixnum
  23   "The exclusive upper bound on the number of parameters which may be specified
  24   in a given lambda list. This is actually the limit on required and &OPTIONAL
  25   parameters. With &KEY and &AUX you can get more.")
  26 (defconstant sb!xc:multiple-values-limit sb!xc:most-positive-fixnum
  27   "The exclusive upper bound on the number of multiple VALUES that you can
  28   return.")
  29 \f
  30 ;;;; cross-compiler-only versions of CL special variables, so that we
  31 ;;;; don't have weird interactions with the host compiler
  32
  33 (defvar sb!xc:*compile-file-pathname*)
  34 (defvar sb!xc:*compile-file-truename*)
  35 (defvar sb!xc:*compile-print*)
  36 (defvar sb!xc:*compile-verbose*)
  37 \f
  38 ;;;; miscellaneous types used both in the cross-compiler and on the target
  39
  40 ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
  41 ;;;; somewhere else, not "early-c", since they're after all not part
  42 ;;;; of the compiler.
  43
  44 ;;; the type of LAYOUT-DEPTHOID slot values
  45 (def!type layout-depthoid () '(or index (integer -1 -1)))
  46 (def!type layout-bitmap ()
  47   ;; FIXME: Probably should exclude negative bignum
  48   #!+compact-instance-header 'integer
  49   #!-compact-instance-header '(and integer (not (eql 0))))
  50 \f
  51 ;;; An INLINEP value describes how a function is called. The values
  52 ;;; have these meanings:
  53 ;;;     NIL     No declaration seen: do whatever you feel like, but don't
  54 ;;;             dump an inline expansion.
  55 ;;; :NOTINLINE  NOTINLINE declaration seen: always do full function call.
  56 ;;;    :INLINE  INLINE declaration seen: save expansion, expanding to it
  57 ;;;             if policy favors.
  58 ;;; :MAYBE-INLINE
  59 ;;;             Retain expansion, but only use it opportunistically.
  60 ;;;             :MAYBE-INLINE is quite different from :INLINE. As explained
  61 ;;;             by APD on #lisp 2005-11-26: "MAYBE-INLINE lambda is
  62 ;;;             instantiated once per component, INLINE - for all
  63 ;;;             references (even under #'without FUNCALL)."
  64 (deftype inlinep ()
  65   '(member :inline :maybe-inline :notinline nil))
  66 (defconstant-eqx +inlinep-translations+
  67   '((inline . :inline)
  68     (notinline . :notinline)
  69     (maybe-inline . :maybe-inline))
  70   #'equal)
  71
  72 ;;; *FREE-VARS* translates from the names of variables referenced
  73 ;;; globally to the LEAF structures for them. *FREE-FUNS* is like
  74 ;;; *FREE-VARS*, only it deals with function names.
  75 (defvar *free-vars*)
  76 (defvar *free-funs*)
  77 (declaim (type hash-table *free-vars* *free-funs*))
  78
  79 ;;; We use the same CONSTANT structure to represent all equal anonymous
  80 ;;; constants. This hashtable translates from constants to the LEAFs that
  81 ;;; represent them.
  82 (defvar *constants*)
  83 (declaim (type hash-table *constants*))
  84
  85 ;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
  86 ;;; insertion of instrumenting code (like a (CATCH ...)) around code
  87 ;;; to allow the debugger RETURN and STEP commands to function (we
  88 ;;; disallow it for internal stuff).
  89 (defvar *allow-instrumenting*)
  90
  91 ;;; miscellaneous forward declarations
  92 (defvar *code-segment*)
  93 ;; FIXME: this is a kludge due to the absence of a 'vop' argument
  94 ;; to ALLOCATION-TRAMP in the x86-64 backend.
  95 (defvar *code-is-immobile*)
  96 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
  97 (defvar *component-being-compiled*)
  98 (defvar *compiler-error-context*)
  99 (defvar *compiler-error-count*)
 100 (defvar *compiler-warning-count*)
 101 (defvar *compiler-style-warning-count*)
 102 (defvar *compiler-note-count*)
 103 (defvar *compiler-trace-output*)
 104 (defvar *constraint-universe*)
 105 (defvar *current-path*)
 106 (defvar *current-component*)
 107 (defvar *delayed-ir1-transforms*)
 108 (defvar *dynamic-counts-tn*)
 109 (defvar *elsewhere*)
 110 (defvar *elsewhere-label*)
 111 (defvar *event-info*)
 112 (defvar *event-note-threshold*)
 113 (defvar *failure-p*)
 114 (defvar *fixup-notes*)
 115 #!+inline-constants
 116 (progn
 117   (defvar *unboxed-constants*)
 118   (defstruct (unboxed-constants (:conc-name constant-)
 119                                 (:predicate nil) (:copier nil))
 120     (table (make-hash-table :test #'equal) :read-only t)
 121     (segment
 122      (sb!assem:make-segment :type :elsewhere
 123                             :run-scheduler nil
 124                             :inst-hook (default-segment-inst-hook)
 125                             :alignment 0) :read-only t)
 126     (vector (make-array 16 :adjustable t :fill-pointer 0) :read-only t))
 127   (declaim (freeze-type unboxed-constants)))
 128 (defvar *source-info*)
 129 (defvar *source-plist*)
 130 (defvar *source-namestring*)
 131 (defvar *undefined-warnings*)
 132 (defvar *warnings-p*)
 133 (defvar *lambda-conversions*)
 134 (defvar *compile-object* nil)
 135 (defvar *msan-compatible-stack-unpoison* nil)
 136
 137 (defvar *stack-allocate-dynamic-extent* t
 138   "If true (the default), the compiler respects DYNAMIC-EXTENT declarations
 139 and stack allocates otherwise inaccessible parts of the object whenever
 140 possible. Potentially long (over one page in size) vectors are, however, not
 141 stack allocated except in zero SAFETY code, as such a vector could overflow
 142 the stack without triggering overflow protection.")
 143
 144 (!begin-collecting-cold-init-forms)
 145 ;;; This lock is seized in the compiler, and related areas -- like the
 146 ;;; classoid/layout/class system.
 147 (defglobal **world-lock** nil)
 148 #-sb-xc-host
 149 (!cold-init-forms
 150  (setf **world-lock** (sb!thread:make-mutex :name "World Lock")))
 151 (!defun-from-collected-cold-init-forms !world-lock-cold-init)
 152
 153 (defmacro with-world-lock (() &body body)
 154   `(sb!thread:with-recursive-lock (**world-lock**)
 155      ,@body))
 156
 157 (declaim (type fixnum *compiler-sset-counter*))
 158 (defvar *compiler-sset-counter* 0)
 159
 160 ;;; unique ID for the next object created (to let us track object
 161 ;;; identity even across GC, useful for understanding weird compiler
 162 ;;; bugs where something is supposed to be unique but is instead
 163 ;;; exists as duplicate objects)
 164 #!+sb-show
 165 (progn
 166   (defvar *object-id-counter* 0)
 167   (defun new-object-id ()
 168     (prog1
 169         *object-id-counter*
 170       (incf *object-id-counter*))))
 171 \f
 172 ;;;; miscellaneous utilities
 173
 174 ;;; This is for "observers" who want to know if type names have been added.
 175 ;;; Rather than registering listeners, they can detect changes by comparing
 176 ;;; their stored nonce to the current nonce. Additionally the observers
 177 ;;; can detect whether function definitions have occurred.
 178 (declaim (fixnum *type-cache-nonce*))
 179 (!defglobal *type-cache-nonce* 0)
 180
 181 (def!struct (undefined-warning
 182             #-no-ansi-print-object
 183             (:print-object (lambda (x s)
 184                              (print-unreadable-object (x s :type t)
 185                                (prin1 (undefined-warning-name x) s))))
 186             (:copier nil))
 187   ;; the name of the unknown thing
 188   (name nil :type (or symbol list))
 189   ;; the kind of reference to NAME
 190   (kind (missing-arg) :type (member :function :type :variable))
 191   ;; the number of times this thing was used
 192   (count 0 :type unsigned-byte)
 193   ;; a list of COMPILER-ERROR-CONTEXT structures describing places
 194   ;; where this thing was used. Note that we only record the first
 195   ;; *UNDEFINED-WARNING-LIMIT* calls.
 196   (warnings () :type list))
 197
 198 ;;; Delete any undefined warnings for NAME and KIND. This is for the
 199 ;;; benefit of the compiler, but it's sometimes called from stuff like
 200 ;;; type-defining code which isn't logically part of the compiler.
 201 (declaim (ftype (function ((or symbol cons) keyword) (values))
 202                 note-name-defined))
 203 (defun note-name-defined (name kind)
 204   #-sb-xc-host (atomic-incf *type-cache-nonce*)
 205   ;; We do this BOUNDP check because this function can be called when
 206   ;; not in a compilation unit (as when loading top level forms).
 207   (when (boundp '*undefined-warnings*)
 208     (let ((name (uncross name)))
 209       (setq *undefined-warnings*
 210             (delete-if (lambda (x)
 211                          (and (equal (undefined-warning-name x) name)
 212                               (eq (undefined-warning-kind x) kind)))
 213                        *undefined-warnings*))))
 214   (values))
 215
 216 ;;; to be called when a variable is lexically bound
 217 (declaim (ftype (function (symbol) (values)) note-lexical-binding))
 218 (defun note-lexical-binding (symbol)
 219     ;; This check is intended to protect us from getting silently
 220     ;; burned when we define
 221     ;;   foo.lisp:
 222     ;;     (DEFVAR *FOO* -3)
 223     ;;     (DEFUN FOO (X) (+ X *FOO*))
 224     ;;   bar.lisp:
 225     ;;     (DEFUN BAR (X)
 226     ;;       (LET ((*FOO* X))
 227     ;;         (FOO 14)))
 228     ;; and then we happen to compile bar.lisp before foo.lisp.
 229   (when (looks-like-name-of-special-var-p symbol)
 230     ;; FIXME: should be COMPILER-STYLE-WARNING?
 231     (style-warn 'asterisks-around-lexical-variable-name
 232                 :format-control
 233                 "using the lexical binding of the symbol ~
 234                  ~/sb-ext:print-symbol-with-prefix/, not the~@
 235                  dynamic binding"
 236                 :format-arguments (list symbol)))
 237   (values))
 238
 239 (def!struct (debug-name-marker (:print-function print-debug-name-marker)
 240                                (:copier nil)))
 241
 242 (defvar *debug-name-level* 4)
 243 (defvar *debug-name-length* 12)
 244 (defvar *debug-name-punt*)
 245 (defvar *debug-name-sharp*)
 246 (defvar *debug-name-ellipsis*)
 247
 248 (defmethod make-load-form ((marker debug-name-marker) &optional env)
 249   (declare (ignore env))
 250   (cond ((eq marker *debug-name-sharp*)
 251          `(if (boundp '*debug-name-sharp*)
 252               *debug-name-sharp*
 253               (make-debug-name-marker)))
 254         ((eq marker *debug-name-ellipsis*)
 255          `(if (boundp '*debug-name-ellipsis*)
 256               *debug-name-ellipsis*
 257               (make-debug-name-marker)))
 258         (t
 259          (warn "Dumping unknown debug-name marker.")
 260          '(make-debug-name-marker))))
 261
 262 (defun print-debug-name-marker (marker stream level)
 263   (declare (ignore level))
 264   (cond ((eq marker *debug-name-sharp*)
 265          (write-char #\# stream))
 266         ((eq marker *debug-name-ellipsis*)
 267          (write-string "..." stream))
 268         (t
 269          (write-string "???" stream))))
 270
 271 (setf *debug-name-sharp* (make-debug-name-marker)
 272       *debug-name-ellipsis* (make-debug-name-marker))
 273
 274 (declaim (ftype (sfunction () list) name-context))
 275 (defun debug-name (type thing &optional context)
 276   (let ((*debug-name-punt* nil))
 277     (labels ((walk (x)
 278                (typecase x
 279                  (cons
 280                   (if (plusp *debug-name-level*)
 281                       (let ((*debug-name-level* (1- *debug-name-level*)))
 282                         (do ((tail (cdr x) (cdr tail))
 283                              (name (cons (walk (car x)) nil)
 284                                    (cons (walk (car tail)) name))
 285                              (n (1- *debug-name-length*) (1- n)))
 286                             ((or (not (consp tail))
 287                                  (not (plusp n))
 288                                  *debug-name-punt*)
 289                              (cond (*debug-name-punt*
 290                                     (setf *debug-name-punt* nil)
 291                                     (nreverse name))
 292                                    ((atom tail)
 293                                     (nconc (nreverse name) (walk tail)))
 294                                    (t
 295                                     (setf *debug-name-punt* t)
 296                                     (nconc (nreverse name) (list *debug-name-ellipsis*)))))))
 297                       *debug-name-sharp*))
 298                  ((or symbol number string)
 299                   x)
 300                  (t
 301                   (type-of x)))))
 302       (let ((name (list* type (walk thing) (when context (name-context)))))
 303         (when (legal-fun-name-p name)
 304           (bug "~S is a legal function name, and cannot be used as a ~
 305                 debug name." name))
 306         name))))
 307
 308 ;;; Set this to NIL to inhibit assembly-level optimization. (For
 309 ;;; compiler debugging, rather than policy control.)
 310 (defvar *assembly-optimize* t)
 311
 312 (in-package "SB!ALIEN")
 313
 314 ;;; Information describing a heap-allocated alien.
 315 (def!struct (heap-alien-info (:copier nil))
 316   ;; The type of this alien.
 317   (type (missing-arg) :type alien-type)
 318   ;; Its name.
 319   (alien-name (missing-arg) :type simple-string)
 320   ;; Data or code?
 321   (datap (missing-arg) :type boolean))
 322 (!set-load-form-method heap-alien-info (:xc :target))