src/cold/set-up-cold-packages.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB-COLD")
  11
  12 ;;; an entry in the table which describes the non-standard part (i.e. not
  13 ;;; CL/CL-USER/KEYWORD) of the package structure of the SBCL system
  14 ;;;
  15 ;;; We make no attempt to be fully general; our table doesn't need to be
  16 ;;; able to express features which we don't happen to use.
  17 (export '(genesis
  18           package-data
  19           make-package-data
  20           package-data-name
  21           package-data-export
  22           package-data-reexport
  23           package-data-import-from
  24           package-data-use))
  25 (defstruct package-data
  26   ;; a string designator for the package name
  27   (name (error "missing PACKAGE-DATA-NAME datum"))
  28   ;; a doc string
  29   (doc (error "missing PACKAGE-DOC datum"))
  30   ;; a tree containing names for exported symbols which'll be set up at package
  31   ;; creation time, and NILs, which are ignored. (This is a tree in order to
  32   ;; allow constructs like '("ENOSPC" #!+LINUX ("EDQUOT" "EISNAM" "ENAVAIL"
  33   ;; "EREMOTEIO")) to be used in initialization. NIL entries in the tree are
  34   ;; ignored for the same reason of notational convenience.)
  35   export
  36   ;; a list of string designators for exported symbols which don't necessarily
  37   ;; originate in this package (so their EXPORT operations should be handled
  38   ;; after USE operations have been done, so that duplicates aren't created)
  39   reexport
  40   ;; a list of sublists describing imports. Each sublist has the format as an
  41   ;; IMPORT-FROM list in DEFPACKAGE: the first element is the name of the
  42   ;; package to import from, and the remaining elements are the names of
  43   ;; symbols to import.
  44   import-from
  45   ;; a tree of string designators for package names of other packages
  46   ;; which this package uses
  47   use)
  48
  49 ;; The running-in-the-host-Lisp Python cross-compiler defines its
  50 ;; own versions of a number of functions which should not overwrite
  51 ;; host-Lisp functions. Instead we put them in a special package.
  52 ;;
  53 ;; The common theme of the functions, macros, constants, and so
  54 ;; forth in this package is that they run in the host and affect the
  55 ;; compilation of the target.
  56 ;;
  57 ;; FIXME: this package should have only one name, not two,
  58 ;; and its one name should be SBCL, but changing it to that
  59 ;; would entail touching about 900 lines.
  60 (let ((package-name "SB!XC"))
  61   (make-package package-name :use nil :nicknames nil)
  62   (dolist (name '(;; the constants (except for T and NIL which have
  63                   ;; a specially hacked correspondence between
  64                   ;; cross-compilation host Lisp and target Lisp)
  65                   "ARRAY-DIMENSION-LIMIT"
  66                   "ARRAY-RANK-LIMIT"
  67                   "ARRAY-TOTAL-SIZE-LIMIT"
  68                   "BOOLE-1"
  69                   "BOOLE-2"
  70                   "BOOLE-AND"
  71                   "BOOLE-ANDC1"
  72                   "BOOLE-ANDC2"
  73                   "BOOLE-C1"
  74                   "BOOLE-C2"
  75                   "BOOLE-CLR"
  76                   "BOOLE-EQV"
  77                   "BOOLE-IOR"
  78                   "BOOLE-NAND"
  79                   "BOOLE-NOR"
  80                   "BOOLE-ORC1"
  81                   "BOOLE-ORC2"
  82                   "BOOLE-SET"
  83                   "BOOLE-XOR"
  84                   "CALL-ARGUMENTS-LIMIT"
  85                   "CHAR-CODE-LIMIT"
  86                   "DOUBLE-FLOAT-EPSILON"
  87                   "DOUBLE-FLOAT-NEGATIVE-EPSILON"
  88                   "INTERNAL-TIME-UNITS-PER-SECOND"
  89                   "LAMBDA-LIST-KEYWORDS"
  90                   "LAMBDA-PARAMETERS-LIMIT"
  91                   "LEAST-NEGATIVE-DOUBLE-FLOAT"
  92                   "LEAST-NEGATIVE-LONG-FLOAT"
  93                   "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT"
  94                   "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT"
  95                   "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT"
  96                   "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT"
  97                   "LEAST-NEGATIVE-SHORT-FLOAT"
  98                   "LEAST-NEGATIVE-SINGLE-FLOAT"
  99                   "LEAST-POSITIVE-DOUBLE-FLOAT"
 100                   "LEAST-POSITIVE-LONG-FLOAT"
 101                   "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT"
 102                   "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT"
 103                   "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT"
 104                   "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT"
 105                   "LEAST-POSITIVE-SHORT-FLOAT"
 106                   "LEAST-POSITIVE-SINGLE-FLOAT"
 107                   "LONG-FLOAT-EPSILON"
 108                   "LONG-FLOAT-NEGATIVE-EPSILON"
 109                   "MOST-NEGATIVE-DOUBLE-FLOAT"
 110                   "MOST-NEGATIVE-FIXNUM"
 111                   "MOST-NEGATIVE-LONG-FLOAT"
 112                   "MOST-NEGATIVE-SHORT-FLOAT"
 113                   "MOST-NEGATIVE-SINGLE-FLOAT"
 114                   "MOST-POSITIVE-DOUBLE-FLOAT"
 115                   "MOST-POSITIVE-FIXNUM"
 116                   "MOST-POSITIVE-LONG-FLOAT"
 117                   "MOST-POSITIVE-SHORT-FLOAT"
 118                   "MOST-POSITIVE-SINGLE-FLOAT"
 119                   "MULTIPLE-VALUES-LIMIT"
 120                   "PI"
 121                   "SHORT-FLOAT-EPSILON"
 122                   "SHORT-FLOAT-NEGATIVE-EPSILON"
 123                   "SINGLE-FLOAT-EPSILON"
 124                   "SINGLE-FLOAT-NEGATIVE-EPSILON"
 125
 126                   ;; everything else which needs a separate
 127                   ;; existence in xc and target
 128                   "BYTE" "BYTE-POSITION" "BYTE-SIZE"
 129                   "CHAR-CODE"
 130                   "CODE-CHAR"
 131                   "COMPILE-FILE"
 132                   "COMPILE-FILE-PATHNAME"
 133                   "*COMPILE-FILE-PATHNAME*"
 134                   "*COMPILE-FILE-TRUENAME*"
 135                   "*COMPILE-PRINT*"
 136                   "*COMPILE-VERBOSE*"
 137                   "COMPILER-MACRO-FUNCTION"
 138                   "CONSTANTP"
 139                   "DEFCONSTANT"
 140                   "DEFINE-MODIFY-MACRO"
 141                   "DEFINE-SETF-EXPANDER"
 142                   "DEFMACRO" "DEFSETF" "DEFSTRUCT" "DEFTYPE"
 143                   "DEPOSIT-FIELD" "DPB"
 144                   "GENSYM" "*GENSYM-COUNTER*"
 145                   "GET-SETF-EXPANSION"
 146                   "LDB" "LDB-TEST"
 147                   "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION"
 148                   "MACRO-FUNCTION"
 149                   "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*"
 150                   "MAKE-LOAD-FORM"
 151                   "MAKE-LOAD-FORM-SAVING-SLOTS"
 152                   "MASK-FIELD"
 153                   "PROCLAIM"
 154                   "SPECIAL-OPERATOR-P"
 155                   "SUBTYPEP"
 156                   "TYPE-OF" "TYPEP"
 157                   "UPGRADED-ARRAY-ELEMENT-TYPE"
 158                   "UPGRADED-COMPLEX-PART-TYPE"
 159                   "WITH-COMPILATION-UNIT"))
 160       (export (intern name package-name) package-name)))
 161
 162 ;; Symbols that we want never to accidentally see the host's definition of.
 163 (defparameter *shadowing-imports*
 164   (mapcar (lambda (name) (find-symbol name "SB!XC"))
 165           '("BYTE" "BYTE-POSITION" "BYTE-SIZE"
 166             "DPB" "LDB" "LDB-TEST"
 167             "DEPOSIT-FIELD" "MASK-FIELD")))
 168
 169 (let ((package-data-list (read-from-file "package-data-list.lisp-expr")))
 170   (labels ((flatten (tree)
 171              (mapcan (lambda (x) (if (listp x) (flatten x) (list x)))
 172                      tree)))
 173
 174     ;; Build all packages that we need, and initialize them as far as we
 175     ;; can without referring to any other packages.
 176     (dolist (package-data package-data-list)
 177       (let* ((package (make-package
 178                        (package-data-name package-data)
 179                        ;; Note: As of 0.7.0, the only nicknames we use
 180                        ;; for our implementation packages are hacks
 181                        ;; not needed at cross-compile time (e.g. the
 182                        ;; deprecated SB-C-CALL nickname for SB-ALIEN).
 183                        ;; So support for nicknaming during xc is gone,
 184                        ;; since any nicknames are hacked in during
 185                        ;; cold init.
 186                        :nicknames nil
 187                        :use nil)))
 188         (shadowing-import *shadowing-imports* package)
 189         ;; Walk the tree of exported names, exporting each name.
 190         (dolist (string (flatten (package-data-export package-data)))
 191           (export (intern string package) package))))
 192
 193     ;; Now that all packages exist, we can set up package-package
 194     ;; references.
 195     (dolist (package-data package-data-list)
 196       (use-package (package-data-use package-data)
 197                    (package-data-name package-data))
 198       (dolist (sublist (package-data-import-from package-data))
 199         (let* ((from-package (first sublist))
 200                (symbol-names (rest sublist))
 201                (symbols (mapcar (lambda (name)
 202                                   ;; old way, broke for importing symbols
 203                                   ;; like SB!C::DEBUG-SOURCE-FORM into
 204                                   ;; SB!DI -- WHN 19990714
 205                                   #+nil
 206                                   (let ((s (find-symbol name from-package)))
 207                                     (unless s
 208                                       (error "can't find ~S in ~S"
 209                                              name
 210                                              from-package))
 211                                     s)
 212                                   ;; new way, works for SB!DI stuff
 213                                   ;; -- WHN 19990714
 214                                   (intern name from-package))
 215                                 (flatten symbol-names))))
 216           (import symbols (package-data-name package-data)))))
 217
 218     ;; Now that all package-package references exist, we can handle
 219     ;; REEXPORT operations. (We have to wait until now because they
 220     ;; interact with USE operations.)  This code handles dependencies
 221     ;; properly, but is somewhat ugly.
 222     (let (done)
 223       (labels
 224           ((reexport (package-data)
 225              (let ((package (find-package (package-data-name package-data))))
 226                (cond
 227                  ((member package done))
 228                  ((null (package-data-reexport package-data))
 229                   (push package done))
 230                  (t
 231                   (mapcar #'reexport
 232                           (remove-if-not
 233                            (lambda (x)
 234                              (member x (package-data-use package-data)
 235                                      :test #'string=))
 236                            package-data-list
 237                            :key #'package-data-name))
 238                   (dolist (symbol-name
 239                            (flatten (package-data-reexport package-data)))
 240                     (multiple-value-bind (symbol status)
 241                         (find-symbol symbol-name package)
 242                       (unless status
 243                         (error "No symbol named ~S is accessible in ~S."
 244                                symbol-name package))
 245                       (when (eq (symbol-package symbol) package)
 246                         (error
 247                          "~S is not inherited/imported, but native to ~S."
 248                          symbol-name package))
 249                       (export symbol package)))
 250                   (push package done))))))
 251         (dolist (x package-data-list)
 252           (reexport x))
 253         (assert (= (length done) (length package-data-list)))))))
 254
 255 (defun make-assembler-package (pkg-name)
 256   (when (find-package pkg-name)
 257     (delete-package pkg-name))
 258   (let ((pkg (make-package pkg-name
 259                            :use '("CL" "SB!INT" "SB!EXT" "SB!KERNEL" "SB!VM"
 260                                   "SB!SYS" ; for SAP accessors
 261                                   ;; Dependence of the assembler on the compiler
 262                                   ;; feels a bit backwards, but assembly needs
 263                                   ;; TN-SC, TN-OFFSET, etc. because the compiler
 264                                   ;; doesn't speak the assembler's language.
 265                                   ;; Rather vice-versa.
 266                                   "SB!C"))))
 267     (shadowing-import *shadowing-imports* pkg)
 268     ;; Both SB-ASSEM and SB-DISASSEM export these two symbols.
 269     ;; Neither is shadowing-imported. If you need one, package-qualify it.
 270     (shadow '("SEGMENT" "MAKE-SEGMENT") pkg)
 271     (use-package '("SB!ASSEM" "SB!DISASSEM") pkg)
 272     pkg))
 273
 274 ;; Each backend should have a different package for its instruction set
 275 ;; so that they can co-exist.
 276 (make-assembler-package (backend-asm-package-name))
 277
 278 (defun package-list-for-genesis ()
 279   (append (read-from-file "package-data-list.lisp-expr")
 280           (let ((asm-package (backend-asm-package-name)))
 281             (list (make-package-data
 282                    :name asm-package
 283                    :use (mapcar 'package-name
 284                                 (package-use-list asm-package))
 285                    :doc nil)))))