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-number*)
  92 (defvar *count-vop-usages*)
  93 (defvar *current-path*)
  94 (defvar *current-component*)
  95 (defvar *delayed-ir1-transforms*)
  96 (defvar *handled-conditions*)
  97 (defvar *disabled-package-locks*)
  98 (defvar *policy*)
  99 (defvar *dynamic-counts-tn*)
 100 (defvar *elsewhere*)
 101 (defvar *event-info*)
 102 (defvar *event-note-threshold*)
 103 (defvar *failure-p*)
 104 (defvar *fixup-notes*)
 105 (defvar *in-pack*)
 106 (defvar *info-environment*)
 107 (defvar *lexenv*)
 108 (defvar *source-info*)
 109 (defvar *trace-table*)
 110 (defvar *undefined-warnings*)
 111 (defvar *warnings-p*)
 112 (defvar *lambda-conversions*)
 113
 114 ;;; This lock is seized in the compiler, and related areas: the
 115 ;;; compiler is not presently thread-safe
 116 (defvar *big-compiler-lock*
 117   (sb!thread:make-mutex :name "big compiler lock"))
 118
 119 (declaim (type fixnum *compiler-sset-counter*))
 120 (defvar *compiler-sset-counter* 0)
 121
 122 ;;; unique ID for the next object created (to let us track object
 123 ;;; identity even across GC, useful for understanding weird compiler
 124 ;;; bugs where something is supposed to be unique but is instead
 125 ;;; exists as duplicate objects)
 126 #!+sb-show
 127 (progn
 128   (defvar *object-id-counter* 0)
 129   (defun new-object-id ()
 130     (prog1
 131         *object-id-counter*
 132       (incf *object-id-counter*))))
 133 \f
 134 ;;;; miscellaneous utilities
 135
 136 ;;; Delete any undefined warnings for NAME and KIND. This is for the
 137 ;;; benefit of the compiler, but it's sometimes called from stuff like
 138 ;;; type-defining code which isn't logically part of the compiler.
 139 (declaim (ftype (function ((or symbol cons) keyword) (values))
 140                 note-name-defined))
 141 (defun note-name-defined (name kind)
 142   ;; We do this BOUNDP check because this function can be called when
 143   ;; not in a compilation unit (as when loading top level forms).
 144   (when (boundp '*undefined-warnings*)
 145     (setq *undefined-warnings*
 146           (delete-if (lambda (x)
 147                        (and (equal (undefined-warning-name x) name)
 148                             (eq (undefined-warning-kind x) kind)))
 149                      *undefined-warnings*)))
 150   (values))
 151
 152 ;;; to be called when a variable is lexically bound
 153 (declaim (ftype (function (symbol) (values)) note-lexical-binding))
 154 (defun note-lexical-binding (symbol)
 155     ;; This check is intended to protect us from getting silently
 156     ;; burned when we define
 157     ;;   foo.lisp:
 158     ;;     (DEFVAR *FOO* -3)
 159     ;;     (DEFUN FOO (X) (+ X *FOO*))
 160     ;;   bar.lisp:
 161     ;;     (DEFUN BAR (X)
 162     ;;       (LET ((*FOO* X))
 163     ;;         (FOO 14)))
 164     ;; and then we happen to compile bar.lisp before foo.lisp.
 165   (when (looks-like-name-of-special-var-p symbol)
 166     ;; FIXME: should be COMPILER-STYLE-WARNING?
 167     (style-warn "using the lexical binding of the symbol ~S, not the~@
 168 dynamic binding, even though the symbol name follows the usual naming~@
 169 convention (names like *FOO*) for special variables" symbol))
 170   (values))
 171
 172 (def!struct (debug-name-marker (:make-load-form-fun dump-debug-name-marker)
 173                                (:print-function print-debug-name-marker)))
 174
 175 (defvar *debug-name-level* 4)
 176 (defvar *debug-name-length* 12)
 177 (defvar *debug-name-punt*)
 178 (defvar *debug-name-sharp*)
 179 (defvar *debug-name-ellipsis*)
 180
 181 (eval-when (:compile-toplevel :load-toplevel :execute)
 182   (defun dump-debug-name-marker (marker &optional env)
 183     (declare (ignore env))
 184     (cond ((eq marker *debug-name-sharp*)
 185            `(if (boundp '*debug-name-sharp*)
 186                 *debug-name-sharp*
 187                 (make-debug-name-marker)))
 188           ((eq marker *debug-name-ellipsis*)
 189            `(if (boundp '*debug-name-ellipsis*)
 190                 *debug-name-ellipsis*
 191                 (make-debug-name-marker)))
 192           (t
 193            (warn "Dumping unknown debug-name marker.")
 194            '(make-debug-name-marker)))))
 195
 196 (defun print-debug-name-marker (marker stream level)
 197   (declare (ignore level))
 198   (cond ((eq marker *debug-name-sharp*)
 199          (write-char #\# stream))
 200         ((eq marker *debug-name-ellipsis*)
 201          (write-string "..." stream))
 202         (t
 203          (write-string "???" stream))))
 204
 205 (setf *debug-name-sharp* (make-debug-name-marker)
 206       *debug-name-ellipsis* (make-debug-name-marker))
 207
 208 (defun debug-name (type thing)
 209   (let ((*debug-name-punt* nil))
 210     (labels ((walk (x)
 211                (typecase x
 212                  (cons
 213                   (if (plusp *debug-name-level*)
 214                       (let ((*debug-name-level* (1- *debug-name-level*)))
 215                         (do ((tail (cdr x) (cdr tail))
 216                              (name (cons (walk (car x)) nil)
 217                                    (cons (walk (car tail)) name))
 218                              (n (1- *debug-name-length*) (1- n)))
 219                             ((or (not (consp tail))
 220                                  (not (plusp n))
 221                                  *debug-name-punt*)
 222                              (cond (*debug-name-punt*
 223                                     (setf *debug-name-punt* nil)
 224                                     (nreverse name))
 225                                    ((atom tail)
 226                                     (nconc (nreverse name) (walk tail)))
 227                                    (t
 228                                     (setf *debug-name-punt* t)
 229                                     (nconc (nreverse name) (list *debug-name-ellipsis*)))))))
 230                       *debug-name-sharp*))
 231                  ((or symbol number string)
 232                   x)
 233                  (t
 234                   (type-of x)))))
 235       (let ((name (list type (walk thing))))
 236         (when (legal-fun-name-p name)
 237           (bug "~S is a legal function name, and cannot be used as a ~
 238                 debug name." name))
 239         name))))