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 (def!constant sb!xc:call-arguments-limit sb!xc:most-positive-fixnum
  20   #!+sb-doc
  21   "The exclusive upper bound on the number of arguments which may be passed
  22   to a function, including &REST args.")
  23 (def!constant sb!xc:lambda-parameters-limit sb!xc:most-positive-fixnum
  24   #!+sb-doc
  25   "The exclusive upper bound on the number of parameters which may be specifed
  26   in a given lambda list. This is actually the limit on required and &OPTIONAL
  27   parameters. With &KEY and &AUX you can get more.")
  28 (def!constant sb!xc:multiple-values-limit sb!xc:most-positive-fixnum
  29   #!+sb-doc
  30   "The exclusive upper bound on the number of multiple VALUES that you can
  31   return.")
  32 \f
  33 ;;;; cross-compiler-only versions of CL special variables, so that we
  34 ;;;; don't have weird interactions with the host compiler
  35
  36 (defvar sb!xc:*compile-file-pathname*)
  37 (defvar sb!xc:*compile-file-truename*)
  38 (defvar sb!xc:*compile-print*)
  39 (defvar sb!xc:*compile-verbose*)
  40 \f
  41 ;;;; miscellaneous types used both in the cross-compiler and on the target
  42
  43 ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
  44 ;;;; somewhere else, not "early-c", since they're after all not part
  45 ;;;; of the compiler.
  46
  47 ;;; the type of LAYOUT-DEPTHOID slot values
  48 (def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
  49 \f
  50 ;;; possible values for the INLINE-ness of a function.
  51 (deftype inlinep ()
  52   '(member :inline :maybe-inline :notinline nil))
  53 (defparameter *inlinep-translations*
  54   '((inline . :inline)
  55     (notinline . :notinline)
  56     (maybe-inline . :maybe-inline)))
  57
  58 ;;; the lexical environment we are currently converting in
  59 (defvar *lexenv*)
  60 (declaim (type lexenv *lexenv*))
  61
  62 ;;; *FREE-VARS* translates from the names of variables referenced
  63 ;;; globally to the LEAF structures for them. *FREE-FUNS* is like
  64 ;;; *FREE-VARS*, only it deals with function names.
  65 (defvar *free-vars*)
  66 (defvar *free-funs*)
  67 (declaim (type hash-table *free-vars* *free-funs*))
  68
  69 ;;; We use the same CONSTANT structure to represent all equal anonymous
  70 ;;; constants. This hashtable translates from constants to the LEAFs that
  71 ;;; represent them.
  72 (defvar *constants*)
  73 (declaim (type hash-table *constants*))
  74
  75 ;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
  76 ;;; insertion of instrumenting code (like a (CATCH ...)) around code
  77 ;;; to allow the debugger RETURN and STEP commands to function (we
  78 ;;; disallow it for internal stuff).
  79 (defvar *allow-instrumenting*)
  80
  81 ;;; miscellaneous forward declarations
  82 (defvar *code-segment*)
  83 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
  84 (defvar *component-being-compiled*)
  85 (defvar *compiler-error-context*)
  86 (defvar *compiler-error-count*)
  87 (defvar *compiler-warning-count*)
  88 (defvar *compiler-style-warning-count*)
  89 (defvar *compiler-note-count*)
  90 (defvar *compiler-trace-output*)
  91 (defvar *constraint-universe*)
  92 (defvar *count-vop-usages*)
  93 (defvar *current-path*)
  94 (defvar *current-component*)
  95 (defvar *delayed-ir1-transforms*)
  96 (defvar *eval-tlf-index*)
  97 (defvar *handled-conditions*)
  98 (defvar *disabled-package-locks*)
  99 (defvar *policy*)
 100 (defvar *dynamic-counts-tn*)
 101 (defvar *elsewhere*)
 102 (defvar *event-info*)
 103 (defvar *event-note-threshold*)
 104 (defvar *failure-p*)
 105 (defvar *fixup-notes*)
 106 (defvar *in-pack*)
 107 (defvar *info-environment*)
 108 #!+inline-constants
 109 (progn
 110   (defvar *constant-segment*)
 111   (defvar *constant-table*)
 112   (defvar *constant-vector*))
 113 (defvar *lexenv*)
 114 (defvar *source-info*)
 115 (defvar *source-plist*)
 116 (defvar *source-namestring*)
 117 (defvar *trace-table*)
 118 (defvar *undefined-warnings*)
 119 (defvar *warnings-p*)
 120 (defvar *lambda-conversions*)
 121
 122 (defvar *stack-allocate-dynamic-extent* t
 123   "If true (the default), the compiler respects DYNAMIC-EXTENT declarations
 124 and stack allocates otherwise inaccessible parts of the object whenever
 125 possible. Potentially long (over one page in size) vectors are, however, not
 126 stack allocated except in zero SAFETY code, as such a vector could overflow
 127 the stack without triggering overflow protection.")
 128
 129 (!begin-collecting-cold-init-forms)
 130 ;;; This lock is seized in the compiler, and related areas -- like the
 131 ;;; classoid/layout/class system.
 132 (defglobal **world-lock** nil)
 133 (!cold-init-forms
 134  (setf **world-lock** (sb!thread:make-mutex :name "World Lock")))
 135 (!defun-from-collected-cold-init-forms !world-lock-cold-init)
 136
 137 (defmacro with-world-lock (() &body body)
 138   `(sb!thread:with-recursive-lock (**world-lock**)
 139      ,@body))
 140
 141 (declaim (type fixnum *compiler-sset-counter*))
 142 (defvar *compiler-sset-counter* 0)
 143
 144 ;;; unique ID for the next object created (to let us track object
 145 ;;; identity even across GC, useful for understanding weird compiler
 146 ;;; bugs where something is supposed to be unique but is instead
 147 ;;; exists as duplicate objects)
 148 #!+sb-show
 149 (progn
 150   (defvar *object-id-counter* 0)
 151   (defun new-object-id ()
 152     (prog1
 153         *object-id-counter*
 154       (incf *object-id-counter*))))
 155 \f
 156 ;;;; miscellaneous utilities
 157
 158 ;;; Delete any undefined warnings for NAME and KIND. This is for the
 159 ;;; benefit of the compiler, but it's sometimes called from stuff like
 160 ;;; type-defining code which isn't logically part of the compiler.
 161 (declaim (ftype (function ((or symbol cons) keyword) (values))
 162                 note-name-defined))
 163 (defun note-name-defined (name kind)
 164   ;; We do this BOUNDP check because this function can be called when
 165   ;; not in a compilation unit (as when loading top level forms).
 166   (when (boundp '*undefined-warnings*)
 167     (setq *undefined-warnings*
 168           (delete-if (lambda (x)
 169                        (and (equal (undefined-warning-name x) name)
 170                             (eq (undefined-warning-kind x) kind)))
 171                      *undefined-warnings*)))
 172   (values))
 173
 174 ;;; to be called when a variable is lexically bound
 175 (declaim (ftype (function (symbol) (values)) note-lexical-binding))
 176 (defun note-lexical-binding (symbol)
 177     ;; This check is intended to protect us from getting silently
 178     ;; burned when we define
 179     ;;   foo.lisp:
 180     ;;     (DEFVAR *FOO* -3)
 181     ;;     (DEFUN FOO (X) (+ X *FOO*))
 182     ;;   bar.lisp:
 183     ;;     (DEFUN BAR (X)
 184     ;;       (LET ((*FOO* X))
 185     ;;         (FOO 14)))
 186     ;; and then we happen to compile bar.lisp before foo.lisp.
 187   (when (looks-like-name-of-special-var-p symbol)
 188     ;; FIXME: should be COMPILER-STYLE-WARNING?
 189     (style-warn 'sb!kernel:asterisks-around-lexical-variable-name
 190                 :format-control
 191                 "using the lexical binding of the symbol ~
 192                  ~/sb-impl::print-symbol-with-prefix/, not the~@
 193                  dynamic binding"
 194                 :format-arguments (list symbol)))
 195   (values))
 196
 197 (def!struct (debug-name-marker (:make-load-form-fun dump-debug-name-marker)
 198                                (:print-function print-debug-name-marker)))
 199
 200 (defvar *debug-name-level* 4)
 201 (defvar *debug-name-length* 12)
 202 (defvar *debug-name-punt*)
 203 (defvar *debug-name-sharp*)
 204 (defvar *debug-name-ellipsis*)
 205
 206 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 207   (defun dump-debug-name-marker (marker &optional env)
 208     (declare (ignore env))
 209     (cond ((eq marker *debug-name-sharp*)
 210            `(if (boundp '*debug-name-sharp*)
 211                 *debug-name-sharp*
 212                 (make-debug-name-marker)))
 213           ((eq marker *debug-name-ellipsis*)
 214            `(if (boundp '*debug-name-ellipsis*)
 215                 *debug-name-ellipsis*
 216                 (make-debug-name-marker)))
 217           (t
 218            (warn "Dumping unknown debug-name marker.")
 219            '(make-debug-name-marker)))))
 220
 221 (defun print-debug-name-marker (marker stream level)
 222   (declare (ignore level))
 223   (cond ((eq marker *debug-name-sharp*)
 224          (write-char #\# stream))
 225         ((eq marker *debug-name-ellipsis*)
 226          (write-string "..." stream))
 227         (t
 228          (write-string "???" stream))))
 229
 230 (setf *debug-name-sharp* (make-debug-name-marker)
 231       *debug-name-ellipsis* (make-debug-name-marker))
 232
 233 (defun debug-name (type thing &optional context)
 234   (let ((*debug-name-punt* nil))
 235     (labels ((walk (x)
 236                (typecase x
 237                  (cons
 238                   (if (plusp *debug-name-level*)
 239                       (let ((*debug-name-level* (1- *debug-name-level*)))
 240                         (do ((tail (cdr x) (cdr tail))
 241                              (name (cons (walk (car x)) nil)
 242                                    (cons (walk (car tail)) name))
 243                              (n (1- *debug-name-length*) (1- n)))
 244                             ((or (not (consp tail))
 245                                  (not (plusp n))
 246                                  *debug-name-punt*)
 247                              (cond (*debug-name-punt*
 248                                     (setf *debug-name-punt* nil)
 249                                     (nreverse name))
 250                                    ((atom tail)
 251                                     (nconc (nreverse name) (walk tail)))
 252                                    (t
 253                                     (setf *debug-name-punt* t)
 254                                     (nconc (nreverse name) (list *debug-name-ellipsis*)))))))
 255                       *debug-name-sharp*))
 256                  ((or symbol number string)
 257                   x)
 258                  (t
 259                   (type-of x)))))
 260       (let ((name (list* type (walk thing) (when context (name-context)))))
 261         (when (legal-fun-name-p name)
 262           (bug "~S is a legal function name, and cannot be used as a ~
 263                 debug name." name))
 264         name))))