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 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 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 most-positive-fixnum
  29   #!+sb-doc
  30   "The exclusive upper bound on the number of multiple VALUES that you can
  31   return.")
  32
  33 (defconstant-eqx sb!xc:lambda-list-keywords
  34   '(&allow-other-keys
  35     &aux
  36     &body
  37     &environment
  38     &key
  39     &more
  40     &optional
  41     &rest
  42     &whole)
  43   #'equal
  44   #!+sb-doc
  45   "symbols which are magical in a lambda list")
  46 \f
  47 ;;;; cross-compiler-only versions of CL special variables, so that we
  48 ;;;; don't have weird interactions with the host compiler
  49
  50 (defvar sb!xc:*compile-file-pathname*)
  51 (defvar sb!xc:*compile-file-truename*)
  52 (defvar sb!xc:*compile-print*)
  53 (defvar sb!xc:*compile-verbose*)
  54 \f
  55 ;;;; miscellaneous types used both in the cross-compiler and on the target
  56
  57 ;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
  58 ;;;; somewhere else, not "early-c", since they're after all not part
  59 ;;;; of the compiler.
  60
  61 ;;; the type of LAYOUT-DEPTHOID slot values
  62 (def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
  63 \f
  64 ;;; possible values for the INLINE-ness of a function.
  65 (deftype inlinep ()
  66   '(member :inline :maybe-inline :notinline nil))
  67 (defparameter *inlinep-translations*
  68   '((inline . :inline)
  69     (notinline . :notinline)
  70     (maybe-inline . :maybe-inline)))
  71
  72 ;;; the lexical environment we are currently converting in
  73 (defvar *lexenv*)
  74 (declaim (type lexenv *lexenv*))
  75
  76 ;;; *FREE-VARS* translates from the names of variables referenced
  77 ;;; globally to the LEAF structures for them. *FREE-FUNS* is like
  78 ;;; *FREE-VARS*, only it deals with function names.
  79 (defvar *free-vars*)
  80 (defvar *free-funs*)
  81 (declaim (type hash-table *free-vars* *free-funs*))
  82
  83 ;;; We use the same CONSTANT structure to represent all equal anonymous
  84 ;;; constants. This hashtable translates from constants to the LEAFs that
  85 ;;; represent them.
  86 (defvar *constants*)
  87 (declaim (type hash-table *constants*))
  88
  89 ;;; miscellaneous forward declarations
  90 (defvar *code-segment*)
  91 #!+sb-dyncount (defvar *collect-dynamic-statistics*)
  92 (defvar *component-being-compiled*)
  93 (defvar *compiler-error-context*)
  94 (defvar *compiler-error-count*)
  95 (defvar *compiler-warning-count*)
  96 (defvar *compiler-style-warning-count*)
  97 (defvar *compiler-note-count*)
  98 (defvar *compiler-trace-output*)
  99 (defvar *constraint-number*)
 100 (defvar *count-vop-usages*)
 101 (defvar *current-path*)
 102 (defvar *current-component*)
 103 (defvar *delayed-ir1-transforms*)
 104 (defvar *handled-conditions*)
 105 (defvar *disabled-package-locks*)
 106 (defvar *policy*)
 107 (defvar *dynamic-counts-tn*)
 108 (defvar *elsewhere*)
 109 (defvar *event-info*)
 110 (defvar *event-note-threshold*)
 111 (defvar *failure-p*)
 112 (defvar *fixup-notes*)
 113 (defvar *in-pack*)
 114 (defvar *info-environment*)
 115 (defvar *lexenv*)
 116 (defvar *source-info*)
 117 (defvar *trace-table*)
 118 (defvar *undefined-warnings*)
 119 (defvar *warnings-p*)
 120
 121 ;;; This lock is seized in the compiler, and related areas: the
 122 ;;; compiler is not presently thread-safe
 123 (defvar *big-compiler-lock*
 124   (sb!thread:make-mutex :name "big compiler lock"))
 125
 126 ;;; unique ID for the next object created (to let us track object
 127 ;;; identity even across GC, useful for understanding weird compiler
 128 ;;; bugs where something is supposed to be unique but is instead
 129 ;;; exists as duplicate objects)
 130 #!+sb-show
 131 (progn
 132   (defvar *object-id-counter* 0)
 133   (defun new-object-id ()
 134     (prog1
 135         *object-id-counter*
 136       (incf *object-id-counter*))))
 137 \f
 138 ;;;; miscellaneous utilities
 139
 140 ;;; Delete any undefined warnings for NAME and KIND. This is for the
 141 ;;; benefit of the compiler, but it's sometimes called from stuff like
 142 ;;; type-defining code which isn't logically part of the compiler.
 143 (declaim (ftype (function ((or symbol cons) keyword) (values))
 144                 note-name-defined))
 145 (defun note-name-defined (name kind)
 146   ;; We do this BOUNDP check because this function can be called when
 147   ;; not in a compilation unit (as when loading top level forms).
 148   (when (boundp '*undefined-warnings*)
 149     (setq *undefined-warnings*
 150           (delete-if (lambda (x)
 151                        (and (equal (undefined-warning-name x) name)
 152                             (eq (undefined-warning-kind x) kind)))
 153                      *undefined-warnings*)))
 154   (values))
 155
 156 ;;; to be called when a variable is lexically bound
 157 (declaim (ftype (function (symbol) (values)) note-lexical-binding))
 158 (defun note-lexical-binding (symbol)
 159     ;; This check is intended to protect us from getting silently
 160     ;; burned when we define
 161     ;;   foo.lisp:
 162     ;;     (DEFVAR *FOO* -3)
 163     ;;     (DEFUN FOO (X) (+ X *FOO*))
 164     ;;   bar.lisp:
 165     ;;     (DEFUN BAR (X)
 166     ;;       (LET ((*FOO* X))
 167     ;;         (FOO 14)))
 168     ;; and then we happen to compile bar.lisp before foo.lisp.
 169   (when (looks-like-name-of-special-var-p symbol)
 170     ;; FIXME: should be COMPILER-STYLE-WARNING?
 171     (style-warn "using the lexical binding of the symbol ~S, not the~@
 172 dynamic binding, even though the symbol name follows the usual naming~@
 173 convention (names like *FOO*) for special variables" symbol))
 174   (values))
 175
 176 ;;; Hacky (duplicating machinery found elsewhere because this function
 177 ;;; turns out to be on a critical path in the compiler) shorthand for
 178 ;;; creating debug names from source names or other stems, e.g.
 179 ;;;
 180 ;;;   (DEBUG-NAMIFY "FLET " SOURCE-NAME) -> "FLET FOO:BAR"
 181 ;;;   (DEBUG-NAMIFY "top level form " FORM) -> "top level form (QUUX :FOO)"
 182 ;;;
 183 ;;; If ALT is given it must be a string -- it is then used in place of
 184 ;;; either HEAD or TAIL if either of them is EQ to SB-C::.ANONYMOUS.
 185 ;;;
 186 (declaim (inline debug-namify))
 187 (defun debug-namify (head tail &optional alt)
 188   (declare (type (or null string) alt))
 189   (flet ((symbol-debug-name (symbol)
 190            ;; KLUDGE: (OAOOM warning) very much akin to OUTPUT-SYMBOL.
 191            (if (and alt (eq '.anonymous. symbol))
 192                alt
 193                (let ((package (symbol-package symbol))
 194                      (name (symbol-name symbol)))
 195                  (cond
 196                    ((eq package *keyword-package*)
 197                     (concatenate 'string ":" name))
 198                    ((eq package *cl-package*)
 199                     name)
 200                    ((null package)
 201                     (concatenate 'string "#:" name))
 202                    (t
 203                     (multiple-value-bind (symbol status)
 204                         (find-symbol name package)
 205                       (declare (ignore symbol))
 206                       (concatenate 'string
 207                                    (package-name package)
 208                                    (if (eq status :external) ":" "::")
 209                                    name))))))))
 210     (cond ((and (stringp head) (stringp tail))
 211            (concatenate 'string head tail))
 212           ((and (stringp head) (symbolp tail))
 213            (concatenate 'string head (symbol-debug-name tail)))
 214           ((and (symbolp head) (stringp tail))
 215            (concatenate 'string (symbol-debug-name head) tail))
 216           (t
 217            (macrolet ((out (obj s)
 218                         `(typecase ,obj
 219                           (string (write-string ,obj ,s))
 220                           (symbol (write-string (symbol-debug-name ,obj) ,s))
 221                           (t (prin1 ,obj ,s)))))
 222              (with-standard-io-syntax
 223                (let ((*print-readably* nil)
 224                      (*print-pretty* nil)
 225                      (*package* *cl-package*)
 226                      (*print-length* 3)
 227                      (*print-level* 2))
 228                  (with-output-to-string (s)
 229                    (out head s)
 230                    (out tail s)))))))))