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