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