src/code/early-extensions.lisp

   1 ;;;; This file contains definitions and declarations for the
   2 ;;;; EXTENSIONS package which must be available at early cross-compile
   3 ;;;; time, and perhaps also some things which might as well be built
   4 ;;;; at cross-compile time even if they're not strictly needed, since
   5 ;;;; that's harmless. Things which can't be built at cross-compile
   6 ;;;; time (e.g. because they need machinery which only exists inside
   7 ;;;; CMU CL's implementation of the LISP package) do not belong in
   8 ;;;; this file.
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  13 ;;;; This software is derived from the CMU CL system, which was
  14 ;;;; written at Carnegie Mellon University and released into the
  15 ;;;; public domain. The software is in the public domain and is
  16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  17 ;;;; files for more information.
  18
  19 (in-package "SB!IMPL")
  20
  21 ;;; something not EQ to anything we might legitimately READ
  22 (defparameter *eof-object* (make-symbol "EOF-OBJECT"))
  23
  24 ;;; a type used for indexing into arrays, and for related quantities
  25 ;;; like lengths of lists
  26 ;;;
  27 ;;; It's intentionally limited to one less than the
  28 ;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
  29 ;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
  30 ;;; that lets the system know it can increment a value of this type
  31 ;;; without having to worry about using a bignum to represent the
  32 ;;; result.
  33 ;;;
  34 ;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
  35 ;;; bound because ANSI specifies it as an exclusive bound.)
  36 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
  37
  38 ;;; the default value used for initializing character data. The ANSI
  39 ;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
  40 ;;; because it's not in the ANSI table of portable characters.
  41 (defconstant default-init-char #\space)
  42
  43 ;;; CHAR-CODE values for ASCII characters which we care about but
  44 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
  45 ;;; ANSI specification for Lisp
  46 ;;;
  47 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
  48 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
  49 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
  50 ;;; annoying overhead. I should check whether this is happening, and
  51 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
  52 ;;; (or just find a nicer way of expressing characters portably?) --
  53 ;;; WHN 19990713
  54 (defconstant bell-char-code 7)
  55 (defconstant tab-char-code 9)
  56 (defconstant form-feed-char-code 12)
  57 (defconstant return-char-code 13)
  58 (defconstant escape-char-code 27)
  59 (defconstant rubout-char-code 127)
  60 \f
  61 ;;;; miscellaneous iteration extensions
  62
  63 (defmacro dovector ((elt vector &optional result) &rest forms)
  64   #!+sb-doc
  65   "just like DOLIST, but with one-dimensional arrays"
  66   (let ((index (gensym))
  67         (length (gensym))
  68         (vec (gensym)))
  69     `(let ((,vec ,vector))
  70        (declare (type vector ,vec))
  71        (do ((,index 0 (1+ ,index))
  72             (,length (length ,vec)))
  73            ((>= ,index ,length) ,result)
  74          (let ((,elt (aref ,vec ,index)))
  75            ,@forms)))))
  76
  77 (defmacro dohash ((key-var value-var table &optional result) &body body)
  78   #!+sb-doc
  79   "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
  80    Iterate over the entries in a hash-table."
  81   (multiple-value-bind (forms decls) (parse-body body nil)
  82     (let ((gen (gensym))
  83           (n-more (gensym)))
  84       `(with-hash-table-iterator (,gen ,table)
  85          (loop
  86           (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
  87             ,@decls
  88             (unless ,n-more (return ,result))
  89             ,@forms))))))
  90 \f
  91 ;;;; hash cache utility
  92
  93 (eval-when (:compile-toplevel :load-toplevel :execute)
  94   (defvar *profile-hash-cache* nil))
  95
  96 ;;; a flag for whether it's too early in cold init to use caches so
  97 ;;; that we have a better chance of recovering so that we have a
  98 ;;; better chance of getting the system running so that we have a
  99 ;;; better chance of diagnosing the problem which caused us to use the
 100 ;;; caches too early
 101 #!+sb-show
 102 (defvar *hash-caches-initialized-p*)
 103
 104 ;;; Define a hash cache that associates some number of argument values
 105 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
 106 ;;; is used to compare the value for that arg in a cache entry with a
 107 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
 108 ;;; its first arg, but need not return any particular value.
 109 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
 110 ;;;
 111 ;;; NAME is used to define these functions:
 112 ;;; <name>-CACHE-LOOKUP Arg*
 113 ;;;   See whether there is an entry for the specified ARGs in the
 114 ;;;   cache. If not present, the :DEFAULT keyword (default NIL)
 115 ;;;   determines the result(s).
 116 ;;; <name>-CACHE-ENTER Arg* Value*
 117 ;;;   Encache the association of the specified args with VALUE.
 118 ;;; <name>-CACHE-CLEAR
 119 ;;;   Reinitialize the cache, invalidating all entries and allowing
 120 ;;;   the arguments and result values to be GC'd.
 121 ;;;
 122 ;;; These other keywords are defined:
 123 ;;; :HASH-BITS <n>
 124 ;;;   The size of the cache as a power of 2.
 125 ;;; :HASH-FUNCTION function
 126 ;;;   Some thing that can be placed in CAR position which will compute
 127 ;;;   a value between 0 and (1- (expt 2 <hash-bits>)).
 128 ;;; :VALUES <n>
 129 ;;;   the number of return values cached for each function call
 130 ;;; :INIT-WRAPPER <name>
 131 ;;;   The code for initializing the cache is wrapped in a form with
 132 ;;;   the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
 133 ;;;   in type system definitions so that caches will be created
 134 ;;;   before top-level forms run.)
 135 (defmacro define-hash-cache (name args &key hash-function hash-bits default
 136                                   (init-wrapper 'progn)
 137                                   (values 1))
 138   (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
 139          (nargs (length args))
 140          (entry-size (+ nargs values))
 141          (size (ash 1 hash-bits))
 142          (total-size (* entry-size size))
 143          (default-values (if (and (consp default) (eq (car default) 'values))
 144                              (cdr default)
 145                              (list default)))
 146          (n-index (gensym))
 147          (n-cache (gensym)))
 148
 149     (unless (= (length default-values) values)
 150       (error "The number of default values ~S differs from :VALUES ~D."
 151              default values))
 152
 153     (collect ((inlines)
 154               (forms)
 155               (inits)
 156               (tests)
 157               (sets)
 158               (arg-vars)
 159               (values-indices)
 160               (values-names))
 161       (dotimes (i values)
 162         (values-indices `(+ ,n-index ,(+ nargs i)))
 163         (values-names (gensym)))
 164       (let ((n 0))
 165         (dolist (arg args)
 166           (unless (= (length arg) 2)
 167             (error "bad argument spec: ~S" arg))
 168           (let ((arg-name (first arg))
 169                 (test (second arg)))
 170             (arg-vars arg-name)
 171             (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
 172             (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
 173           (incf n)))
 174
 175       (when *profile-hash-cache*
 176         (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
 177               (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
 178           (inits `(setq ,n-probe 0))
 179           (inits `(setq ,n-miss 0))
 180           (forms `(defvar ,n-probe))
 181           (forms `(defvar ,n-miss))
 182           (forms `(declaim (fixnum ,n-miss ,n-probe)))))
 183
 184       (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
 185         (inlines fun-name)
 186         (forms
 187          `(defun ,fun-name ,(arg-vars)
 188             ,@(when *profile-hash-cache*
 189                 `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))
 190             (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
 191                   (,n-cache ,var-name))
 192               (declare (type fixnum ,n-index))
 193               (cond ((and ,@(tests))
 194                      (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
 195                                        (values-indices))))
 196                     (t
 197                      ,@(when *profile-hash-cache*
 198                          `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
 199                      ,default))))))
 200
 201       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
 202         (inlines fun-name)
 203         (forms
 204          `(defun ,fun-name (,@(arg-vars) ,@(values-names))
 205             (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
 206                   (,n-cache ,var-name))
 207               (declare (type fixnum ,n-index))
 208               ,@(sets)
 209               ,@(mapcar #'(lambda (i val)
 210                             `(setf (svref ,n-cache ,i) ,val))
 211                         (values-indices)
 212                         (values-names))
 213               (values)))))
 214
 215       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
 216         (forms
 217          `(defun ,fun-name ()
 218             (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
 219                  (,n-cache ,var-name))
 220                 ((minusp ,n-index))
 221               (declare (type fixnum ,n-index))
 222               ,@(collect ((arg-sets))
 223                   (dotimes (i nargs)
 224                     (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
 225                   (arg-sets))
 226               ,@(mapcar #'(lambda (i val)
 227                             `(setf (svref ,n-cache ,i) ,val))
 228                         (values-indices)
 229                         default-values))
 230             (values)))
 231         (forms `(,fun-name)))
 232
 233       (inits `(unless (boundp ',var-name)
 234                 (setq ,var-name (make-array ,total-size))))
 235       #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
 236
 237       `(progn
 238          (defvar ,var-name)
 239          (declaim (type (simple-vector ,total-size) ,var-name))
 240          #!-sb-fluid (declaim (inline ,@(inlines)))
 241          (,init-wrapper ,@(inits))
 242          ,@(forms)
 243          ',name))))
 244
 245 ;;; some syntactic sugar for defining a function whose values are
 246 ;;; cached by DEFINE-HASH-CACHE
 247 (defmacro defun-cached ((name &rest options &key (values 1) default
 248                               &allow-other-keys)
 249                         args &body body-decls-doc)
 250   (let ((default-values (if (and (consp default) (eq (car default) 'values))
 251                             (cdr default)
 252                             (list default)))
 253         (arg-names (mapcar #'car args)))
 254     (collect ((values-names))
 255       (dotimes (i values)
 256         (values-names (gensym)))
 257       (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
 258         `(progn
 259            (define-hash-cache ,name ,args ,@options)
 260            (defun ,name ,arg-names
 261              ,@decls
 262              ,doc
 263              (cond #!+sb-show
 264                    ((not (boundp '*hash-caches-initialized-p*))
 265                     ;; This shouldn't happen, but it did happen to me
 266                     ;; when revising the type system, and it's a lot
 267                     ;; easier to figure out what what's going on with
 268                     ;; that kind of problem if the system can be kept
 269                     ;; alive until cold boot is complete. The recovery
 270                     ;; mechanism should definitely be conditional on
 271                     ;; some debugging feature (e.g. SB-SHOW) because
 272                     ;; it's big, duplicating all the BODY code. -- WHN
 273                     (/show0 ,name " too early in cold init, uncached")
 274                     (/show0 ,(first arg-names) "=..")
 275                     (/hexstr ,(first arg-names))
 276                     ,@body)
 277                    (t
 278                     (multiple-value-bind ,(values-names)
 279                         (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
 280                       (if (and ,@(mapcar (lambda (val def)
 281                                            `(eq ,val ,def))
 282                                          (values-names) default-values))
 283                           (multiple-value-bind ,(values-names)
 284                               (progn ,@body)
 285                             (,(symbolicate name "-CACHE-ENTER") ,@arg-names
 286                              ,@(values-names))
 287                             (values ,@(values-names)))
 288                           (values ,@(values-names))))))))))))
 289 \f
 290 ;;;; package idioms
 291
 292 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
 293 ;;; instead of this function. (The distinction only actually matters when
 294 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
 295 ;;; you generally do want to signal an error instead of proceeding.)
 296 (defun %find-package-or-lose (package-designator)
 297   (or (find-package package-designator)
 298       (error 'sb!kernel:simple-package-error
 299              :package package-designator
 300              :format-control "The name ~S does not designate any package."
 301              :format-arguments (list package-designator))))
 302
 303 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
 304 ;;; consequences of most operations on deleted packages are
 305 ;;; unspecified. We try to signal errors in such cases.
 306 (defun find-undeleted-package-or-lose (package-designator)
 307   (let ((maybe-result (%find-package-or-lose package-designator)))
 308     (if (package-name maybe-result)     ; if not deleted
 309         maybe-result
 310         (error 'sb!kernel:simple-package-error
 311                :package maybe-result
 312                :format-control "The package ~S has been deleted."
 313                :format-arguments (list maybe-result)))))
 314 \f
 315 ;;;; miscellany
 316
 317 ;;; Is NAME a legal function name?
 318 (defun legal-function-name-p (name)
 319   (or (symbolp name)
 320       (and (consp name)
 321            (eq (car name) 'setf)
 322            (consp (cdr name))
 323            (symbolp (cadr name))
 324            (null (cddr name)))))
 325
 326 ;;; Given a function name, return the name for the BLOCK which
 327 ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
 328 (declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
 329 (defun function-name-block-name (function-name)
 330   (cond ((symbolp function-name)
 331          function-name)
 332         ((and (consp function-name)
 333               (= (length function-name) 2)
 334               (eq (first function-name) 'setf))
 335          (second function-name))
 336         (t
 337          (error "not legal as a function name: ~S" function-name))))
 338
 339 ;;; Is X a (possibly-improper) list of at least N elements?
 340 (declaim (ftype (function (t index)) list-of-length-at-least-p))
 341 (defun list-of-length-at-least-p (x n)
 342   (or (zerop n) ; since anything can be considered an improper list of length 0
 343       (and (consp x)
 344            (list-of-length-at-least-p (cdr x) (1- n)))))
 345
 346 ;;; Return a list of N gensyms. (This is a common suboperation in
 347 ;;; macros and other code-manipulating code.)
 348 (declaim (ftype (function (index) list) make-gensym-list))
 349 (defun make-gensym-list (n)
 350   (loop repeat n collect (gensym)))
 351
 352 ;;; ANSI guarantees that some symbols are self-evaluating. This
 353 ;;; function is to be called just before a change which would affect
 354 ;;; that. (We don't absolutely have to call this function before such
 355 ;;; changes, since such changes are given as undefined behavior. In
 356 ;;; particular, we don't if the runtime cost would be annoying. But
 357 ;;; otherwise it's nice to do so.)
 358 (defun about-to-modify (symbol)
 359   (declare (type symbol symbol))
 360   (cond ((eq symbol t)
 361          (error "Veritas aeterna. (can't change T)"))
 362         ((eq symbol nil)
 363          (error "Nihil ex nihil. (can't change NIL)"))
 364         ((keywordp symbol)
 365          (error "Keyword values can't be changed."))
 366         ;; (Just because a value is CONSTANTP is not a good enough
 367         ;; reason to complain here, because we want DEFCONSTANT to
 368         ;; be able to use this function, and it's legal to DEFCONSTANT
 369         ;; a constant as long as the new value is EQL to the old
 370         ;; value.)
 371         ))
 372
 373 ;;; Return a function like FUN, but expecting its (two) arguments in
 374 ;;; the opposite order that FUN does.
 375 (declaim (inline swapped-args-fun))
 376 (defun swapped-args-fun (fun)
 377   (declare (type function fun))
 378   (lambda (x y)
 379     (funcall fun y x)))
 380
 381 ;;; like CL:ASSERT, but lighter-weight
 382 ;;;
 383 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT
 384 ;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a
 385 ;;; significant amount of code when you multiply them by 400, so
 386 ;;; replacing them with this should reduce the size of the system
 387 ;;; by enough to be worthwhile.)
 388 (defmacro aver (expr)
 389   `(unless ,expr
 390      (%failed-aver ,(let ((*package* (find-package :keyword)))
 391                       (format nil "~S" expr)))))
 392 (defun %failed-aver (expr-as-string)
 393   (error "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
 394 \f
 395 ;;;; utilities for two-VALUES predicates
 396
 397 ;;; sort of like ANY and EVERY, except:
 398 ;;;   * We handle two-VALUES predicate functions, as SUBTYPEP does.
 399 ;;;     (And if the result is uncertain, then we return (VALUES NIL NIL),
 400 ;;;     as SUBTYPEP does.)
 401 ;;;   * THING is just an atom, and we apply OP (an arity-2 function)
 402 ;;;     successively to THING and each element of LIST.
 403 (defun any/type (op thing list)
 404   (declare (type function op))
 405   (let ((certain? t))
 406     (dolist (i list (values nil certain?))
 407       (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
 408         (if sub-certain?
 409             (when sub-value (return (values t t)))
 410             (setf certain? nil))))))
 411 (defun every/type (op thing list)
 412   (declare (type function op))
 413   (let ((certain? t))
 414     (dolist (i list (if certain? (values t t) (values nil nil)))
 415       (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
 416         (if sub-certain?
 417             (unless sub-value (return (values nil t)))
 418             (setf certain? nil))))))
 419 \f
 420 ;;;; DEFPRINTER
 421
 422 ;;; These functions are called by the expansion of the DEFPRINTER
 423 ;;; macro to do the actual printing.
 424 (declaim (ftype (function (symbol t stream &optional t) (values))
 425                 defprinter-prin1 defprinter-princ))
 426 (defun defprinter-prin1 (name value stream &optional indent)
 427   (declare (ignore indent))
 428   (defprinter-prinx #'prin1 name value stream))
 429 (defun defprinter-princ (name value stream &optional indent)
 430   (declare (ignore indent))
 431   (defprinter-prinx #'princ name value stream))
 432 (defun defprinter-prinx (prinx name value stream)
 433   (declare (type function prinx))
 434   (when *print-pretty*
 435     (pprint-newline :linear stream))
 436   (format stream ":~A " name)
 437   (funcall prinx value stream)
 438   (values))
 439 (defun defprinter-print-space (stream)
 440   (write-char #\space stream))
 441
 442 ;;; Define some kind of reasonable PRINT-OBJECT method for a
 443 ;;; STRUCTURE-OBJECT class.
 444 ;;;
 445 ;;; NAME is the name of the structure class, and CONC-NAME is the same
 446 ;;; as in DEFSTRUCT.
 447 ;;;
 448 ;;; The SLOT-DESCS describe how each slot should be printed. Each
 449 ;;; SLOT-DESC can be a slot name, indicating that the slot should
 450 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
 451 ;;; and other stuff. The other stuff is composed of keywords followed
 452 ;;; by expressions. The expressions are evaluated with the variable
 453 ;;; which is the slot name bound to the value of the slot. These
 454 ;;; keywords are defined:
 455 ;;;
 456 ;;; :PRIN1    Print the value of the expression instead of the slot value.
 457 ;;; :PRINC    Like :PRIN1, only PRINC the value
 458 ;;; :TEST     Only print something if the test is true.
 459 ;;;
 460 ;;; If no printing thing is specified then the slot value is printed
 461 ;;; as if by PRIN1.
 462 ;;;
 463 ;;; The structure being printed is bound to STRUCTURE and the stream
 464 ;;; is bound to STREAM.
 465 (defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
 466                                                          (symbol-name name)
 467                                                          "-")))
 468                       &rest slot-descs)
 469   (let ((first? t)
 470         maybe-print-space
 471         (reversed-prints nil)
 472         (stream (gensym "STREAM")))
 473     (flet ((sref (slot-name)
 474              `(,(symbolicate conc-name slot-name) structure)))
 475       (dolist (slot-desc slot-descs)
 476         (if first?
 477             (setf maybe-print-space nil
 478                   first? nil)
 479             (setf maybe-print-space `(defprinter-print-space ,stream)))
 480         (cond ((atom slot-desc)
 481                (push maybe-print-space reversed-prints)
 482                (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
 483                      reversed-prints))
 484               (t
 485                (let ((sname (first slot-desc))
 486                      (test t))
 487                  (collect ((stuff))
 488                    (do ((option (rest slot-desc) (cddr option)))
 489                        ((null option)
 490                         (push `(let ((,sname ,(sref sname)))
 491                                  (when ,test
 492                                    ,maybe-print-space
 493                                    ,@(or (stuff)
 494                                          `((defprinter-prin1
 495                                              ',sname ,sname ,stream)))))
 496                               reversed-prints))
 497                      (case (first option)
 498                        (:prin1
 499                         (stuff `(defprinter-prin1
 500                                   ',sname ,(second option) ,stream)))
 501                        (:princ
 502                         (stuff `(defprinter-princ
 503                                   ',sname ,(second option) ,stream)))
 504                        (:test (setq test (second option)))
 505                        (t
 506                         (error "bad option: ~S" (first option)))))))))))
 507     `(def!method print-object ((structure ,name) ,stream)
 508        ;; FIXME: should probably be byte-compiled
 509        (pprint-logical-block (,stream nil)
 510          (print-unreadable-object (structure ,stream :type t)
 511            (when *print-pretty*
 512              (pprint-indent :block 2 ,stream))
 513            ,@(nreverse reversed-prints))))))
 514 \f
 515 #|
 516 ;;; REMOVEME when done testing byte cross-compiler
 517 (defun byte-compiled-foo (x y)
 518   (declare (optimize (speed 0) (debug 1)))
 519   (if x
 520       x
 521       (cons y y)))
 522 |#