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
  15 (file-comment
  16   "$Header$")
  17 \f
  18 ;;;; other miscellaneous stuff
  19
  20 ;;; This returns a form that returns a dual-word aligned number of bytes when
  21 ;;; given a number of words.
  22 ;;;
  23 ;;; FIXME: should be a function
  24 ;;; FIXME: should be called PAD-DATA-BLOCK-SIZE
  25 (defmacro pad-data-block (words)
  26   `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask))
  27 \f
  28 ;;;; primitive object definition stuff
  29
  30 (defun remove-keywords (options keywords)
  31   (cond ((null options) nil)
  32         ((member (car options) keywords)
  33          (remove-keywords (cddr options) keywords))
  34         (t
  35          (list* (car options) (cadr options)
  36                 (remove-keywords (cddr options) keywords)))))
  37
  38 (def!struct (prim-object-slot
  39              (:constructor make-slot (name docs rest-p offset length options))
  40              (:make-load-form-fun just-dump-it-normally)
  41              (:conc-name slot-))
  42   (name nil :type symbol)
  43   (docs nil :type (or null simple-string))
  44   (rest-p nil :type (member t nil))
  45   (offset 0 :type fixnum)
  46   (length 1 :type fixnum)
  47   (options nil :type list))
  48
  49 (def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
  50   (name nil :type symbol)
  51   (header nil :type symbol)
  52   (lowtag nil :type symbol)
  53   (options nil :type list)
  54   (slots nil :type list)
  55   (size 0 :type fixnum)
  56   (variable-length nil :type (member t nil)))
  57
  58 (defvar *primitive-objects* nil)
  59
  60 (defun %define-primitive-object (primobj)
  61   (let ((name (primitive-object-name primobj)))
  62     (setf *primitive-objects*
  63           (cons primobj
  64                 (remove name *primitive-objects*
  65                         :key #'primitive-object-name :test #'eq)))
  66     name))
  67
  68 (defmacro define-primitive-object
  69           ((name &key header lowtag alloc-trans (type t))
  70            &rest slot-specs)
  71   (collect ((slots) (exports) (constants) (forms) (inits))
  72     (let ((offset (if header 1 0))
  73           (variable-length nil))
  74       (dolist (spec slot-specs)
  75         (when variable-length
  76           (error "No more slots can follow a :rest-p slot."))
  77         (destructuring-bind
  78             (slot-name &rest options
  79                        &key docs rest-p (length (if rest-p 0 1))
  80                        ((:type slot-type) t) init
  81                        (ref-known nil ref-known-p) ref-trans
  82                        (set-known nil set-known-p) set-trans
  83                        &allow-other-keys)
  84             (if (atom spec) (list spec) spec)
  85           (slots (make-slot slot-name docs rest-p offset length
  86                             (remove-keywords options
  87                                              '(:docs :rest-p :length))))
  88           (let ((offset-sym (symbolicate name "-" slot-name
  89                                          (if rest-p "-OFFSET" "-SLOT"))))
  90             (constants `(defconstant ,offset-sym ,offset
  91                           ,@(when docs (list docs))))
  92             (exports offset-sym))
  93           (when ref-trans
  94             (when ref-known-p
  95               (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
  96             (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
  97           (when set-trans
  98             (when set-known-p
  99               (forms `(defknown ,set-trans
 100                                 ,(if (listp set-trans)
 101                                      (list slot-type type)
 102                                      (list type slot-type))
 103                                 ,slot-type
 104                         ,set-known)))
 105             (forms `(def-setter ,set-trans ,offset ,lowtag)))
 106           (when init
 107             (inits (cons init offset)))
 108           (when rest-p
 109             (setf variable-length t))
 110           (incf offset length)))
 111       (unless variable-length
 112         (let ((size (symbolicate name "-SIZE")))
 113           (constants `(defconstant ,size ,offset
 114                         ,(format nil
 115                                  "Number of slots used by each ~S~
 116                                   ~@[~* including the header~]."
 117                                  name header)))
 118           (exports size)))
 119       (when alloc-trans
 120         (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
 121                            ,lowtag ',(inits))))
 122       `(progn
 123          (let ((sb!int::*rogue-export* "DEFINE-PRIMITIVE-OBJECT"))
 124            (export ',(exports)))
 125          (eval-when (:compile-toplevel :load-toplevel :execute)
 126            (%define-primitive-object
 127             ',(make-primitive-object :name name
 128                                      :header header
 129                                      :lowtag lowtag
 130                                      :slots (slots)
 131                                      :size offset
 132                                      :variable-length variable-length))
 133            ,@(constants))
 134          ,@(forms)))))
 135 \f
 136 ;;;; stuff for defining reffers and setters
 137
 138 (in-package "SB!C")
 139
 140 (defun %def-reffer (name offset lowtag)
 141   (let ((info (function-info-or-lose name)))
 142     (setf (function-info-ir2-convert info)
 143           #'(lambda (node block)
 144               (ir2-convert-reffer node block name offset lowtag))))
 145   name)
 146
 147 (defmacro def-reffer (name offset lowtag)
 148   `(%def-reffer ',name ,offset ,lowtag))
 149
 150 (defun %def-setter (name offset lowtag)
 151   (let ((info (function-info-or-lose name)))
 152     (setf (function-info-ir2-convert info)
 153           (if (listp name)
 154               #'(lambda (node block)
 155                   (ir2-convert-setfer node block name offset lowtag))
 156               #'(lambda (node block)
 157                   (ir2-convert-setter node block name offset lowtag)))))
 158   name)
 159
 160 (defmacro def-setter (name offset lowtag)
 161   `(%def-setter ',name ,offset ,lowtag))
 162
 163 (defun %def-alloc (name words variable-length header lowtag inits)
 164   (let ((info (function-info-or-lose name)))
 165     (setf (function-info-ir2-convert info)
 166           (if variable-length
 167               #'(lambda (node block)
 168                   (ir2-convert-variable-allocation node block name words header
 169                                                    lowtag inits))
 170               #'(lambda (node block)
 171                   (ir2-convert-fixed-allocation node block name words header
 172                                                 lowtag inits)))))
 173   name)
 174
 175 (defmacro def-alloc (name words variable-length header lowtag inits)
 176   `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))
 177 \f
 178 ;;;; some general constant definitions
 179
 180 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
 181 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
 182 (in-package "SB!C")
 183
 184 ;;; the maximum number of SCs in any implementation
 185 (defconstant sc-number-limit 32)