src/compiler/generic/vm-macs.lisp

   1 ;;;; some macros and constants that are object-format-specific or are
   2 ;;;; used for defining the object format
   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!VM")
  14 \f
  15 ;;;; other miscellaneous stuff
  16
  17 ;;; This returns a form that returns a dual-word aligned number of bytes when
  18 ;;; given a number of words.
  19 ;;;
  20 ;;; FIXME: should be a function
  21 ;;; FIXME: should be called PAD-DATA-BLOCK-SIZE
  22 (defmacro pad-data-block (words)
  23   `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask))
  24 \f
  25 ;;;; primitive object definition stuff
  26
  27 (defun remove-keywords (options keywords)
  28   (cond ((null options) nil)
  29         ((member (car options) keywords)
  30          (remove-keywords (cddr options) keywords))
  31         (t
  32          (list* (car options) (cadr options)
  33                 (remove-keywords (cddr options) keywords)))))
  34
  35 (def!struct (prim-object-slot
  36              (:constructor make-slot (name docs rest-p offset length options))
  37              (:make-load-form-fun just-dump-it-normally)
  38              (:conc-name slot-))
  39   (name nil :type symbol)
  40   (docs nil :type (or null simple-string))
  41   (rest-p nil :type (member t nil))
  42   (offset 0 :type fixnum)
  43   (length 1 :type fixnum)
  44   (options nil :type list))
  45
  46 (def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
  47   (name nil :type symbol)
  48   (widetag nil :type symbol)
  49   (lowtag nil :type symbol)
  50   (options nil :type list)
  51   (slots nil :type list)
  52   (size 0 :type fixnum)
  53   (var-length nil :type (member t nil)))
  54
  55 (defvar *primitive-objects* nil)
  56
  57 (defun %define-primitive-object (primobj)
  58   (let ((name (primitive-object-name primobj)))
  59     (setf *primitive-objects*
  60           (cons primobj
  61                 (remove name *primitive-objects*
  62                         :key #'primitive-object-name :test #'eq)))
  63     name))
  64
  65 (defmacro define-primitive-object
  66           ((name &key lowtag widetag alloc-trans (type t))
  67            &rest slot-specs)
  68   (collect ((slots) (exports) (constants) (forms) (inits))
  69     (let ((offset (if widetag 1 0))
  70           (var-length nil))
  71       (dolist (spec slot-specs)
  72         (when var-length
  73           (error "No more slots can follow a :rest-p slot."))
  74         (destructuring-bind
  75             (slot-name &rest options
  76                        &key docs rest-p (length (if rest-p 0 1))
  77                        ((:type slot-type) t) init
  78                        (ref-known nil ref-known-p) ref-trans
  79                        (set-known nil set-known-p) set-trans
  80                        &allow-other-keys)
  81             (if (atom spec) (list spec) spec)
  82           (slots (make-slot slot-name docs rest-p offset length
  83                             (remove-keywords options
  84                                              '(:docs :rest-p :length))))
  85           (let ((offset-sym (symbolicate name "-" slot-name
  86                                          (if rest-p "-OFFSET" "-SLOT"))))
  87             (constants `(def!constant ,offset-sym ,offset
  88                           ,@(when docs (list docs))))
  89             (exports offset-sym))
  90           (when ref-trans
  91             (when ref-known-p
  92               (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
  93             (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
  94           (when set-trans
  95             (when set-known-p
  96               (forms `(defknown ,set-trans
  97                                 ,(if (listp set-trans)
  98                                      (list slot-type type)
  99                                      (list type slot-type))
 100                                 ,slot-type
 101                         ,set-known)))
 102             (forms `(def-setter ,set-trans ,offset ,lowtag)))
 103           (when init
 104             (inits (cons init offset)))
 105           (when rest-p
 106             (setf var-length t))
 107           (incf offset length)))
 108       (unless var-length
 109         (let ((size (symbolicate name "-SIZE")))
 110           (constants `(def!constant ,size ,offset))
 111           (exports size)))
 112       (when alloc-trans
 113         (forms `(def-alloc ,alloc-trans ,offset ,var-length ,widetag
 114                            ,lowtag ',(inits))))
 115       `(progn
 116          (eval-when (:compile-toplevel :load-toplevel :execute)
 117            (%define-primitive-object
 118             ',(make-primitive-object :name name
 119                                      :widetag widetag
 120                                      :lowtag lowtag
 121                                      :slots (slots)
 122                                      :size offset
 123                                      :var-length var-length))
 124            ,@(constants))
 125          ,@(forms)))))
 126 \f
 127 ;;;; stuff for defining reffers and setters
 128
 129 (in-package "SB!C")
 130
 131 (defmacro def-reffer (name offset lowtag)
 132   `(%def-reffer ',name ,offset ,lowtag))
 133 (defmacro def-setter (name offset lowtag)
 134   `(%def-setter ',name ,offset ,lowtag))
 135 (defmacro def-alloc (name words var-length header lowtag inits)
 136   `(%def-alloc ',name ,words ,var-length ,header ,lowtag ,inits))
 137 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
 138 ;;; are defined later in another file, since they use structure slot
 139 ;;; setters defined later, and we can't have physical forward
 140 ;;; references to structure slot setters because ANSI in its wisdom
 141 ;;; allows the xc host CL to implement structure slot setters as SETF
 142 ;;; expanders instead of SETF functions. -- WHN 2002-02-09
 143 \f
 144 ;;;; some general constant definitions
 145
 146 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
 147 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
 148 (in-package "SB!C")
 149
 150 ;;; the maximum number of SCs in any implementation
 151 (def!constant sc-number-limit 32)