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