src/compiler/arm64/vm.lisp

   1 ;;;; miscellaneous VM definition noise for the ARM
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 \f
  15 ;;;; register specs
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defvar *register-names* (make-array 32 :initial-element nil)))
  19
  20 (macrolet ((defreg (name offset)
  21              (let ((offset-sym (symbolicate name "-OFFSET")))
  22                `(eval-when (:compile-toplevel :load-toplevel :execute)
  23                   (def!constant ,offset-sym ,offset)
  24                   (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
  25
  26            (defregset (name &rest regs)
  27              `(eval-when (:compile-toplevel :load-toplevel :execute)
  28                 (defparameter ,name
  29                   (list ,@(mapcar #'(lambda (name)
  30                                       (symbolicate name "-OFFSET")) regs))))))
  31
  32   (defreg nl0 0)
  33   (defreg nl1 1)
  34   (defreg nl2 2)
  35   (defreg nl3 3)
  36   (defreg nl4 4)
  37   (defreg nl5 5)
  38   (defreg nl6 6)
  39   (defreg nl7 7)
  40   (defreg nl8 8)
  41   (defreg nl9 9)
  42
  43   (defreg r0 10)
  44   (defreg r1 11)
  45   (defreg r2 12)
  46   (defreg r3 13)
  47   (defreg r4 14)
  48   (defreg r5 15)
  49   (defreg r6 16)
  50   (defreg r7 17)
  51   (defreg r8 18)
  52   (defreg r9 19)
  53
  54   #!+sb-thread
  55   (defreg thread 20)
  56   #!-sb-thread
  57   (defreg r10 20)
  58
  59   (defreg lexenv 21)
  60
  61   (defreg nargs 22)
  62   (defreg nfp 23)
  63   (defreg ocfp 24)
  64   (defreg cfp 25)
  65   (defreg csp 26)
  66   (defreg tmp 27)
  67   (defreg null 28)
  68   (defreg code 29)
  69   (defreg lr 30)
  70   (defreg nsp 31)
  71   (defreg zr 31)
  72
  73   (defregset system-regs
  74       null cfp nsp lr code)
  75
  76   (defregset descriptor-regs
  77       r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 #!-sb-thread r10 lexenv)
  78
  79   (defregset non-descriptor-regs
  80       nl0 nl1 nl2 nl3 nl4 nl5 nl6 nl7 nl8 nl9 nargs nfp ocfp)
  81
  82   ;; registers used to pass arguments
  83   ;;
  84   ;; the number of arguments/return values passed in registers
  85   (def!constant register-arg-count 4)
  86   ;; names and offsets for registers used to pass arguments
  87   (defregset *register-arg-offsets*  r0 r1 r2 r3)
  88   (defparameter *register-arg-names* '(r0 r1 r2 r3)))
  89
  90 \f
  91 ;;;; SB and SC definition:
  92
  93 (define-storage-base registers :finite :size 32)
  94 (define-storage-base control-stack :unbounded :size 2 :size-increment 1)
  95 (define-storage-base non-descriptor-stack :unbounded :size 0)
  96 (define-storage-base constant :non-packed)
  97 (define-storage-base immediate-constant :non-packed)
  98 (define-storage-base float-registers :finite :size 32)
  99
 100 ;;;
 101 ;;; Handy macro so we don't have to keep changing all the numbers whenever
 102 ;;; we insert a new storage class.
 103 ;;;
 104 (defmacro define-storage-classes (&rest classes)
 105   (do ((forms (list 'progn)
 106               (let* ((class (car classes))
 107                      (sc-name (car class))
 108                      (constant-name (intern (concatenate 'simple-string
 109                                                          (string sc-name)
 110                                                          "-SC-NUMBER"))))
 111                 (list* `(define-storage-class ,sc-name ,index
 112                           ,@(cdr class))
 113                        `(def!constant ,constant-name ,index)
 114                        forms)))
 115        (index 0 (1+ index))
 116        (classes classes (cdr classes)))
 117       ((null classes)
 118        (nreverse forms))))
 119
 120 (define-storage-classes
 121
 122     ;; Non-immediate contstants in the constant pool
 123     (constant constant)
 124
 125     ;; NULL is in a register.
 126     (null immediate-constant)
 127
 128   ;; Anything else that can be an immediate.
 129   (immediate immediate-constant)
 130
 131
 132   ;; **** The stacks.
 133
 134   ;; The control stack.  (Scanned by GC)
 135   (control-stack control-stack)
 136
 137   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 138   ;; is small and therefore the error trap information is smaller.
 139   ;; Moving them up here from their previous place down below saves
 140   ;; ~250K in core file size.  --njf, 2006-01-27
 141
 142   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 143   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 144   (any-reg
 145    registers
 146    :locations #.(append non-descriptor-regs descriptor-regs)
 147    :constant-scs (immediate)
 148    :save-p t
 149    :alternate-scs (control-stack))
 150
 151   ;; Pointer descriptor objects.  Must be seen by GC.
 152   (descriptor-reg registers
 153                   :locations #.descriptor-regs
 154                   :constant-scs (constant null immediate)
 155                   :save-p t
 156                   :alternate-scs (control-stack))
 157
 158   (32-bit-reg registers
 159               :locations #.(loop for i below 32 collect i))
 160
 161   ;; The non-descriptor stacks.
 162   (signed-stack non-descriptor-stack)    ; (signed-byte 64)
 163   (unsigned-stack non-descriptor-stack)  ; (unsigned-byte 64)
 164   (character-stack non-descriptor-stack) ; non-descriptor characters.
 165   (sap-stack non-descriptor-stack)       ; System area pointers.
 166   (single-stack non-descriptor-stack)    ; single-floats
 167   (double-stack non-descriptor-stack) ; double floats.
 168   (complex-single-stack non-descriptor-stack)
 169   (complex-double-stack non-descriptor-stack :element-size 2 :alignment 2)
 170
 171   ;; **** Things that can go in the integer registers.
 172
 173   ;; Non-Descriptor characters
 174   (character-reg registers
 175                  :locations #.non-descriptor-regs
 176                  :constant-scs (immediate)
 177                  :save-p t
 178                  :alternate-scs (character-stack))
 179
 180   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 181   (sap-reg registers
 182            :locations #.non-descriptor-regs
 183            :constant-scs (immediate)
 184            :save-p t
 185            :alternate-scs (sap-stack))
 186
 187   ;; Non-Descriptor (signed or unsigned) numbers.
 188   (signed-reg registers
 189               :locations #.non-descriptor-regs
 190               :constant-scs (immediate)
 191               :save-p t
 192               :alternate-scs (signed-stack))
 193   (unsigned-reg registers
 194                 :locations #.non-descriptor-regs
 195                 :constant-scs (immediate)
 196                 :save-p t
 197                 :alternate-scs (unsigned-stack))
 198
 199   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 200   (non-descriptor-reg registers
 201                       :locations #.non-descriptor-regs)
 202
 203   ;; Pointers to the interior of objects.  Used only as a temporary.
 204   (interior-reg registers
 205                 :locations (#.lr-offset))
 206
 207   ;; **** Things that can go in the floating point registers.
 208
 209   ;; Non-Descriptor single-floats.
 210   (single-reg float-registers
 211               :locations #.(loop for i below 32 collect i)
 212               :constant-scs ()
 213               :save-p t
 214               :alternate-scs (single-stack))
 215
 216   ;; Non-Descriptor double-floats.
 217   (double-reg float-registers
 218               :locations #.(loop for i below 32 collect i)
 219               :constant-scs ()
 220               :save-p t
 221               :alternate-scs (double-stack))
 222
 223   (complex-single-reg float-registers
 224                       :locations #.(loop for i below 32 collect i)
 225                       :constant-scs ()
 226                       :save-p t
 227                       :alternate-scs (complex-single-stack))
 228
 229   (complex-double-reg float-registers
 230                       :locations #.(loop for i below 32 collect i)
 231                       :constant-scs ()
 232                       :save-p t
 233                       :alternate-scs (complex-double-stack))
 234
 235   (catch-block control-stack :element-size catch-block-size)
 236   (unwind-block control-stack :element-size unwind-block-size))
 237 \f
 238 ;;;; Make some random tns for important registers.
 239
 240 (macrolet ((defregtn (name sc)
 241                (let ((offset-sym (symbolicate name "-OFFSET"))
 242                      (tn-sym (symbolicate name "-TN")))
 243                  `(defparameter ,tn-sym
 244                    (make-random-tn :kind :normal
 245                     :sc (sc-or-lose ',sc)
 246                     :offset ,offset-sym)))))
 247
 248   (defregtn null descriptor-reg)
 249   (defregtn code descriptor-reg)
 250   (defregtn tmp any-reg)
 251
 252   (defregtn nargs any-reg)
 253   (defregtn ocfp any-reg)
 254   (defregtn nsp any-reg)
 255   (defregtn zr any-reg)
 256   (defregtn cfp any-reg)
 257   (defregtn csp any-reg)
 258   (defregtn lr interior-reg)
 259   #!+sb-thread
 260   (defregtn thread interior-reg))
 261 \f
 262 ;;; If VALUE can be represented as an immediate constant, then return the
 263 ;;; appropriate SC number, otherwise return NIL.
 264 (defun immediate-constant-sc (value)
 265   (typecase value
 266     (null
 267      (sc-number-or-lose 'null))
 268     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 269          character)
 270      (sc-number-or-lose 'immediate))
 271     (symbol
 272      (if (static-symbol-p value)
 273          (sc-number-or-lose 'immediate)
 274          nil))))
 275
 276 (defun boxed-immediate-sc-p (sc)
 277   (or (eql sc (sc-number-or-lose 'null))
 278       (eql sc (sc-number-or-lose 'immediate))))
 279 \f
 280 ;;;; function call parameters
 281
 282 ;;; the SC numbers for register and stack arguments/return values
 283 (def!constant immediate-arg-scn (sc-number-or-lose 'any-reg))
 284 (def!constant control-stack-arg-scn (sc-number-or-lose 'control-stack))
 285
 286 ;;; offsets of special stack frame locations
 287 (def!constant ocfp-save-offset 0)
 288 (def!constant lra-save-offset 1)
 289 (def!constant nfp-save-offset 2)
 290
 291 ;;; This is used by the debugger.
 292 ;;; < nyef> Ah, right. So, SINGLE-VALUE-RETURN-BYTE-OFFSET doesn't apply to x86oids or ARM.
 293 (def!constant single-value-return-byte-offset 0)
 294
 295
 296 ;;; A list of TN's describing the register arguments.
 297 ;;;
 298 (defparameter *register-arg-tns*
 299   (mapcar #'(lambda (n)
 300               (make-random-tn :kind :normal
 301                               :sc (sc-or-lose 'descriptor-reg)
 302                               :offset n))
 303           *register-arg-offsets*))
 304 \f
 305 ;;; This function is called by debug output routines that want a pretty name
 306 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 307 (defun location-print-name (tn)
 308   (declare (type tn tn))
 309   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 310         (offset (tn-offset tn)))
 311     (ecase sb
 312       (registers (format nil "~:[~;W~]~A"
 313                          (sc-is tn 32-bit-reg)
 314                          (svref *register-names* offset)))
 315       (control-stack (format nil "CS~D" offset))
 316       (non-descriptor-stack (format nil "NS~D" offset))
 317       (constant (format nil "Const~D" offset))
 318       (immediate-constant "Immed")
 319       (float-registers
 320        (format nil "~A~D"
 321                (sc-case tn
 322                  (single-reg "S")
 323                  ((double-reg complex-single-reg) "D")
 324                  (complex-double-reg "Q"))
 325                offset)))))
 326
 327 (defun combination-implementation-style (node)
 328   (flet ((valid-funtype (args result)
 329            (sb!c::valid-fun-use node
 330                                 (sb!c::specifier-type
 331                                  `(function ,args ,result)))))
 332     (case (sb!c::combination-fun-source-name node)
 333       (logtest
 334        (if (or (valid-funtype '(fixnum fixnum) '*)
 335                (valid-funtype '(signed-word signed-word) '*)
 336                (valid-funtype '(word word) '*))
 337            (values :maybe nil)
 338            (values :default nil)))
 339       (logbitp
 340        (cond
 341          ((or (valid-funtype '((constant-arg (integer 0 #.(1- n-fixnum-bits))) fixnum) '*)
 342               (valid-funtype '((constant-arg (integer 0 #.(1- n-word-bits))) signed-word) '*)
 343               (valid-funtype '((constant-arg (integer 0 #.(1- n-word-bits))) word) '*))
 344           (values :transform '(lambda (index integer)
 345                                (%logbitp integer index))))
 346          (t (values :default nil))))
 347       (%ldb
 348        (flet ((validp (type width)
 349                 (and (valid-funtype `((constant-arg (mod ,width))
 350                                       (constant-arg (mod ,width))
 351                                       ,type)
 352                                     'unsigned-byte)
 353                      (destructuring-bind (size posn integer)
 354                          (sb!c::basic-combination-args node)
 355                        (declare (ignore integer))
 356                        (and (plusp (sb!c::lvar-value posn))
 357                             (<= (+ (sb!c::lvar-value size)
 358                                    (sb!c::lvar-value posn))
 359                                 width))))))
 360          (if (or (validp 'fixnum n-fixnum-bits)
 361                  (validp '(signed-byte 64) 64)
 362                  (validp '(unsigned-byte 64) 64))
 363              (values :transform '(lambda (size posn integer)
 364                                   (%%ldb integer size posn)))
 365              (values :default nil))))
 366       (%dpb
 367        (flet ((validp (type width)
 368                 (and (valid-funtype `(,type
 369                                       (constant-arg (mod ,width))
 370                                       (constant-arg (mod ,width))
 371                                       ,type)
 372                                     'integer)
 373                      (destructuring-bind (newbyte size posn integer)
 374                          (sb!c::basic-combination-args node)
 375                        (declare (ignore integer newbyte))
 376                        (and (plusp (sb!c::lvar-value posn))
 377                             (<= (+ (sb!c::lvar-value size)
 378                                    (sb!c::lvar-value posn))
 379                                 width))))))
 380          (if (or (validp 'fixnum n-fixnum-bits)
 381                  (validp '(signed-byte 64) 64)
 382                  (validp '(unsigned-byte 64) 64))
 383              (values :transform '(lambda (newbyte size posn integer)
 384                                   (%%dpb newbyte size posn integer)))
 385              (values :default nil))))
 386       (t (values :default nil)))))
 387
 388 (defun primitive-type-indirect-cell-type (ptype)
 389   (declare (ignore ptype))
 390   nil)
 391
 392 (defun 32-bit-reg (tn)
 393   (make-random-tn :kind :normal
 394                   :sc (sc-or-lose '32-bit-reg)
 395                   :offset (tn-offset tn)))