src/code/package.lisp

   1 ;;;; that part of the CMU CL package.lisp file which can run on the
   2 ;;;; cross-compilation host
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!IMPL")
  14 \f
  15 ;;;; the PACKAGE-HASHTABLE structure
  16
  17 ;;; comment from CMU CL:
  18 ;;;      Packages are implemented using a special kind of hashtable. It is
  19 ;;;   an open hashtable with a parallel 8-bit I-vector of hash-codes. The
  20 ;;;   primary purpose of the hash for each entry is to reduce paging by
  21 ;;;   allowing collisions and misses to be detected without paging in the
  22 ;;;   symbol and pname for an entry. If the hash for an entry doesn't
  23 ;;;   match that for the symbol that we are looking for, then we can
  24 ;;;   go on without touching the symbol, pname, or even hastable vector.
  25 ;;;      It turns out that, contrary to my expectations, paging is a very
  26 ;;;   important consideration the design of the package representation.
  27 ;;;   Using a similar scheme without the entry hash, the fasloader was
  28 ;;;   spending more than half its time paging in INTERN.
  29 ;;;      The hash code also indicates the status of an entry. If it zero,
  30 ;;;   the entry is unused. If it is one, then it is deleted.
  31 ;;;   Double-hashing is used for collision resolution.
  32
  33 ;; FIXME: too vaguely named. Should be PACKAGE-HASH-VECTOR.
  34 (def!type hash-vector () '(simple-array (unsigned-byte 8) (*)))
  35
  36 (sb!xc:defstruct (package-hashtable
  37                   (:constructor %make-package-hashtable
  38                                 (cells size &aux (free size)))
  39                   (:copier nil))
  40   ;; The general-vector of symbols, with a hash-vector in its last cell.
  41   (cells (missing-arg) :type simple-vector)
  42   ;; The total number of entries allowed before resizing.
  43   ;;
  44   ;; FIXME: CAPACITY would be a more descriptive name. (This is
  45   ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
  46   ;; it SIZE seems somewhat misleading.)
  47   (size (missing-arg) :type index)
  48   ;; The remaining number of entries that can be made before we have to rehash.
  49   (free (missing-arg) :type index)
  50   ;; The number of deleted entries.
  51   (deleted 0 :type index))
  52 \f
  53 ;;;; the PACKAGE structure
  54
  55 (sb!xc:defstruct (package
  56                   (:constructor %make-package
  57                                 (%name internal-symbols external-symbols))
  58                   (:predicate packagep))
  59   #!+sb-doc
  60   "the standard structure for the description of a package"
  61   ;; the name of the package, or NIL for a deleted package
  62   (%name nil :type (or simple-string null))
  63   ;; nickname strings
  64   (%nicknames () :type list)
  65   ;; packages used by this package
  66   (%use-list () :type list)
  67   ;; a simple-vector of the external symbol hashtables for used packages.
  68   ;; Derived from %USE-LIST, but maintained separately.
  69   (tables #() :type simple-vector)
  70   ;; index into TABLES of the table in which an inherited symbol was most
  71   ;; recently found. On the next %FIND-SYMBOL operation, the indexed table
  72   ;; is tested first.
  73   (mru-table-index 0 :type index)
  74   ;; packages that use this package
  75   (%used-by-list () :type list)
  76   ;; PACKAGE-HASHTABLEs of internal & external symbols
  77   (internal-symbols nil :type package-hashtable)
  78   (external-symbols nil :type package-hashtable)
  79   ;; shadowing symbols
  80   ;; Todo: dynamically changeover to a PACKAGE-HASHTABLE if list gets long
  81   (%shadowing-symbols () :type list)
  82   ;; documentation string for this package
  83   (doc-string nil :type (or simple-string null))
  84   ;; package locking
  85   #!+sb-package-locks
  86   (lock nil :type boolean)
  87   #!+sb-package-locks
  88   (%implementation-packages nil :type list)
  89   ;; Definition source location
  90   (source-location nil :type (or null sb!c:definition-source-location))
  91   ;; Local package nicknames.
  92   (%local-nicknames nil :type list)
  93   (%locally-nicknamed-by nil :type list))
  94
  95 #-sb-xc-host
  96 (defmethod make-load-form ((p package) &optional environment)
  97   (declare (ignore environment))
  98   `(find-undeleted-package-or-lose ,(package-name p)))
  99 \f
 100 ;;;; iteration macros
 101
 102 (flet ((expand-iterator (range var body result-form)
 103          (multiple-value-bind (forms decls)
 104              (parse-body body :doc-string-allowed nil)
 105            (with-unique-names (iterator winp next)
 106              `(block nil
 107                 (with-package-iterator (,iterator ,@range)
 108                  (tagbody
 109                   ,next
 110                   (multiple-value-bind (,winp ,var) (,iterator)
 111                     ;; I don't think this VAR is automatically ignorable.
 112                     ;; The user should use it, or declare IGNORE/IGNORABLE.
 113                     ,@decls
 114                     (if ,winp
 115                         (tagbody ,@forms (go ,next))
 116                         (return ,result-form))))))))))
 117
 118 (defmacro-mundanely do-symbols ((var &optional
 119                                      (package '*package*)
 120                                      result-form)
 121                                 &body body-decls)
 122   #!+sb-doc
 123   "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
 124    Executes the FORMs at least once for each symbol accessible in the given
 125    PACKAGE with VAR bound to the current symbol."
 126   (expand-iterator `((find-undeleted-package-or-lose ,package)
 127                      :internal :external :inherited)
 128                    var body-decls result-form))
 129
 130 (defmacro-mundanely do-external-symbols ((var &optional
 131                                               (package '*package*)
 132                                               result-form)
 133                                          &body body-decls)
 134   #!+sb-doc
 135   "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
 136    Executes the FORMs once for each external symbol in the given PACKAGE with
 137    VAR bound to the current symbol."
 138   (expand-iterator `((find-undeleted-package-or-lose ,package) :external)
 139                    var body-decls result-form))
 140
 141 (defmacro-mundanely do-all-symbols ((var &optional
 142                                          result-form)
 143                                     &body body-decls)
 144   #!+sb-doc
 145   "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
 146    Executes the FORMs once for each symbol in every package with VAR bound
 147    to the current symbol."
 148   (expand-iterator '((list-all-packages) :internal :external)
 149                    var body-decls result-form)))
 150
 151 \f
 152 ;;;; WITH-PACKAGE-ITERATOR
 153
 154 (defmacro-mundanely with-package-iterator ((mname package-list
 155                                                   &rest symbol-types)
 156                                            &body body)
 157   #!+sb-doc
 158   "Within the lexical scope of the body forms, MNAME is defined via macrolet
 159 such that successive invocations of (MNAME) will return the symbols, one by
 160 one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any
 161 of :INHERITED :EXTERNAL :INTERNAL."
 162   ;; SYMBOL-TYPES should really be named ACCESSIBILITY-TYPES.
 163   (when (null symbol-types)
 164     (error 'simple-program-error
 165            :format-control
 166            "At least one of :INTERNAL, :EXTERNAL, or :INHERITED must be supplied."))
 167   (dolist (symbol symbol-types)
 168     (unless (member symbol '(:internal :external :inherited))
 169       (error 'simple-program-error
 170              :format-control
 171              "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
 172              :format-arguments (list symbol))))
 173   (with-unique-names (bits index sym-vec pkglist symbol kind)
 174     (let ((state (list bits index sym-vec pkglist))
 175           (select (logior (if (member :internal  symbol-types) 1 0)
 176                           (if (member :external  symbol-types) 2 0)
 177                           (if (member :inherited symbol-types) 4 0))))
 178       `(multiple-value-bind ,state (package-iter-init ,select ,package-list)
 179          (let (,symbol ,kind)
 180            (macrolet
 181                ((,mname ()
 182                    '(if (eql 0 (multiple-value-setq (,@state ,symbol ,kind)
 183                                  (package-iter-step ,@state)))
 184                         nil
 185                         (values t ,symbol ,kind
 186                                 (car (truly-the list ,pkglist))))))
 187              ,@body))))))
 188
 189 (defmacro-mundanely with-package-graph ((&key) &body forms)
 190   `(flet ((thunk () ,@forms))
 191      (declare (dynamic-extent #'thunk))
 192      (call-with-package-graph #'thunk)))