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 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   (options nil :type list))
  44
  45 (def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
  46   (name nil :type symbol)
  47   (widetag nil :type symbol)
  48   (lowtag nil :type symbol)
  49   (options nil :type list)
  50   (slots nil :type list)
  51   (size 0 :type fixnum)
  52   (variable-length-p nil :type (member t nil)))
  53
  54 (defvar *primitive-objects* nil)
  55
  56 (defun %define-primitive-object (primobj)
  57   (let ((name (primitive-object-name primobj)))
  58     (setf *primitive-objects*
  59           (cons primobj
  60                 (remove name *primitive-objects*
  61                         :key #'primitive-object-name :test #'eq)))
  62     name))
  63
  64 (defmacro define-primitive-object
  65           ((name &key lowtag widetag alloc-trans (type t))
  66            &rest slot-specs)
  67   (collect ((slots) (exports) (constants) (forms) (inits))
  68     (let ((offset (if widetag 1 0))
  69           (variable-length-p nil))
  70       (dolist (spec slot-specs)
  71         (when variable-length-p
  72           (error "No more slots can follow a :rest-p slot."))
  73         (destructuring-bind
  74             (slot-name &rest options
  75                        &key docs rest-p (length (if rest-p 0 1))
  76                        ((:type slot-type) t) init
  77                        (ref-known nil ref-known-p) ref-trans
  78                        (set-known nil set-known-p) set-trans
  79                        &allow-other-keys)
  80             (if (atom spec) (list spec) spec)
  81           (slots (make-slot slot-name docs rest-p offset
  82                             (remove-keywords options
  83                                              '(:docs :rest-p :length))))
  84           (let ((offset-sym (symbolicate name "-" slot-name
  85                                          (if rest-p "-OFFSET" "-SLOT"))))
  86             (constants `(def!constant ,offset-sym ,offset
  87                           ,@(when docs (list docs))))
  88             (exports offset-sym))
  89           (when ref-trans
  90             (when ref-known-p
  91               (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
  92             (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
  93           (when set-trans
  94             (when set-known-p
  95               (forms `(defknown ,set-trans
  96                                 ,(if (listp set-trans)
  97                                      (list slot-type type)
  98                                      (list type slot-type))
  99                                 ,slot-type
 100                         ,set-known)))
 101             (forms `(def-setter ,set-trans ,offset ,lowtag)))
 102           (when init
 103             (inits (cons init offset)))
 104           (when rest-p
 105             (setf variable-length-p t))
 106           (incf offset length)))
 107       (unless variable-length-p
 108         (let ((size (symbolicate name "-SIZE")))
 109           (constants `(def!constant ,size ,offset))
 110           (exports size)))
 111       (when alloc-trans
 112         (forms `(def-alloc ,alloc-trans ,offset ,variable-length-p ,widetag
 113                            ,lowtag ',(inits))))
 114       `(progn
 115          (eval-when (:compile-toplevel :load-toplevel :execute)
 116            (%define-primitive-object
 117             ',(make-primitive-object :name name
 118                                      :widetag widetag
 119                                      :lowtag lowtag
 120                                      :slots (slots)
 121                                      :size offset
 122                                      :variable-length-p variable-length-p))
 123            ,@(constants))
 124          ,@(forms)))))
 125 \f
 126 ;;;; stuff for defining reffers and setters
 127
 128 (in-package "SB!C")
 129
 130 (defmacro def-reffer (name offset lowtag)
 131   `(%def-reffer ',name ,offset ,lowtag))
 132 (defmacro def-setter (name offset lowtag)
 133   `(%def-setter ',name ,offset ,lowtag))
 134 (defmacro def-alloc (name words variable-length-p header lowtag inits)
 135   `(%def-alloc ',name ,words ,variable-length-p ,header ,lowtag ,inits))
 136 ;;; KLUDGE: The %DEF-FOO functions used to implement the macros here
 137 ;;; are defined later in another file, since they use structure slot
 138 ;;; setters defined later, and we can't have physical forward
 139 ;;; references to structure slot setters because ANSI in its wisdom
 140 ;;; allows the xc host CL to implement structure slot setters as SETF
 141 ;;; expanders instead of SETF functions. -- WHN 2002-02-09
 142 \f
 143 ;;;; some general constant definitions
 144
 145 ;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
 146 ;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
 147 (in-package "SB!C")
 148
 149 ;;; the maximum number of SCs in any implementation
 150 (def!constant sc-number-limit 32)
 151 \f
 152 ;;; Modular functions
 153
 154 ;;; For a documentation, see CUT-TO-WIDTH.
 155
 156 (defstruct modular-class
 157   ;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
 158   (funs (make-hash-table :test 'eq))
 159   ;; hash: modular-variant -> (prototype width)
 160   ;;
 161   ;; FIXME: Reimplement with generic function names of kind
 162   ;; (MODULAR-VERSION prototype width)
 163   (versions (make-hash-table :test 'eq))
 164   ;; list of increasing widths
 165   (widths nil))
 166 (defvar *unsigned-modular-class* (make-modular-class))
 167 (defvar *signed-modular-class* (make-modular-class))
 168 (defun find-modular-class (kind)
 169   (ecase kind
 170     (:unsigned *unsigned-modular-class*)
 171     (:signed *signed-modular-class*)))
 172
 173 (defstruct modular-fun-info
 174   (name (missing-arg) :type symbol)
 175   (width (missing-arg) :type (integer 0))
 176   (lambda-list (missing-arg) :type list)
 177   (prototype (missing-arg) :type symbol))
 178
 179 (defun find-modular-version (fun-name class width)
 180   (let ((infos (gethash fun-name (modular-class-funs (find-modular-class class)))))
 181     (if (listp infos)
 182         (find-if (lambda (item-width) (>= item-width width))
 183                  infos
 184                  :key #'modular-fun-info-width)
 185         infos)))
 186
 187 ;;; Return (VALUES prototype-name width)
 188 (defun modular-version-info (name class)
 189   (values-list (gethash name (modular-class-versions (find-modular-class class)))))
 190
 191 (defun %define-modular-fun (name lambda-list prototype class width)
 192   (let* ((class (find-modular-class class))
 193          (funs (modular-class-funs class))
 194          (versions (modular-class-versions class))
 195          (infos (the list (gethash prototype funs)))
 196          (info (find-if (lambda (item-width) (= item-width width))
 197                         infos
 198                         :key #'modular-fun-info-width)))
 199     (if info
 200         (unless (and (eq name (modular-fun-info-name info))
 201                      (= (length lambda-list)
 202                         (length (modular-fun-info-lambda-list info))))
 203           (setf (modular-fun-info-name info) name)
 204           (style-warn "Redefining modular version ~S of ~S for width ~S."
 205                       name prototype width))
 206         (setf (gethash prototype funs)
 207               (merge 'list
 208                      (list (make-modular-fun-info :name name
 209                                                   :width width
 210                                                   :lambda-list lambda-list
 211                                                   :prototype prototype))
 212                      infos
 213                      #'< :key #'modular-fun-info-width)
 214               (gethash name versions)
 215               (list prototype width)))
 216     (setf (modular-class-widths class)
 217           (merge 'list (list width) (modular-class-widths class) #'<))))
 218
 219 (defmacro define-modular-fun (name lambda-list prototype class width)
 220   (check-type name symbol)
 221   (check-type prototype symbol)
 222   (check-type class (member :unsigned :signed))
 223   (check-type width unsigned-byte)
 224   (dolist (arg lambda-list)
 225     (when (member arg lambda-list-keywords)
 226       (error "Lambda list keyword ~S is not supported for ~
 227               modular function lambda lists." arg)))
 228   `(progn
 229      (%define-modular-fun ',name ',lambda-list ',prototype ',class ,width)
 230      (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
 231                (,(ecase class
 232                    (:unsigned 'unsigned-byte)
 233                    (:signed 'signed-byte))
 234                  ,width)
 235                (foldable flushable movable)
 236                :derive-type (make-modular-fun-type-deriver
 237                              ',prototype ',class ,width))))
 238
 239 (defun %define-good-modular-fun (name class)
 240   (setf (gethash name (modular-class-funs (find-modular-class class))) :good)
 241   name)
 242
 243 (defmacro define-good-modular-fun (name class)
 244   (check-type name symbol)
 245   (check-type class (member :unsigned :signed))
 246   `(%define-good-modular-fun ',name ',class))
 247
 248 (defmacro define-modular-fun-optimizer
 249     (name ((&rest lambda-list) class &key (width (gensym "WIDTH")))
 250      &body body)
 251   (check-type name symbol)
 252   (check-type class (member :unsigned :signed))
 253   (dolist (arg lambda-list)
 254     (when (member arg lambda-list-keywords)
 255       (error "Lambda list keyword ~S is not supported for ~
 256               modular function lambda lists." arg)))
 257   (with-unique-names (call args)
 258     `(setf (gethash ',name (modular-class-funs (find-modular-class ',class)))
 259            (lambda (,call ,width)
 260              (declare (type basic-combination ,call)
 261                       (type (integer 0) width))
 262              (let ((,args (basic-combination-args ,call)))
 263                (when (= (length ,args) ,(length lambda-list))
 264                  (destructuring-bind ,lambda-list ,args
 265                    (declare (type lvar ,@lambda-list))
 266                    ,@body)))))))