src/compiler/sparc/system.lisp

   1 ;;; -*- Package: SPARC -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written as part of the CMU Common Lisp project at
   5 ;;; Carnegie Mellon University, and has been placed in the public domain.
   6 ;;;
   7 (ext:file-comment
   8   "$Header: src/compiler/sparc/system.lisp $")
   9 ;;;
  10 ;;; **********************************************************************
  11 ;;;
  12 ;;;    MIPS VM definitions of various system hacking operations.
  13 ;;;
  14 ;;; Written by Rob MacLachlan
  15 ;;;
  16 ;;; Mips conversion by William Lott and Christopher Hoover.
  17 ;;;
  18 (in-package "SPARC")
  19 (intl:textdomain "cmucl-sparc-vm")
  20
  21
  22 \f
  23 ;;;; Type frobbing VOPs
  24
  25 (define-vop (get-lowtag)
  26   (:translate get-lowtag)
  27   (:policy :fast-safe)
  28   (:args (object :scs (any-reg descriptor-reg)))
  29   (:results (result :scs (unsigned-reg)))
  30   (:result-types positive-fixnum)
  31   (:generator 1
  32     (inst and result object vm:lowtag-mask)))
  33
  34 (define-vop (get-type)
  35   (:translate get-type)
  36   (:policy :fast-safe)
  37   (:args (object :scs (descriptor-reg) :to (:eval 1)))
  38   (:results (result :scs (unsigned-reg) :from (:eval 0)))
  39   (:result-types positive-fixnum)
  40   (:generator 6
  41     ;; Grab the lowtag.
  42     (inst andcc result object lowtag-mask)
  43     ;; Check for various pointer types.
  44     (inst cmp result list-pointer-type)
  45     (inst b :eq done)
  46     (inst cmp result other-pointer-type)
  47     (inst b :eq other-pointer)
  48     (inst cmp result function-pointer-type)
  49     (inst b :eq function-pointer)
  50     (inst cmp result instance-pointer-type)
  51     (inst b :eq done)
  52     ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
  53     ;; we want the low 8 bits.
  54     (inst andcc zero-tn object vm:fixnum-tag-mask)
  55     (inst b :eq done)
  56     (inst li result 0)                  ; Watch out!  LI in branch delay slot!
  57     ;; It wasn't a fixnum, so get the low 8 bits.
  58     (inst b done)
  59     (inst and result object type-mask)
  60
  61     FUNCTION-POINTER
  62     (inst b done)
  63     (load-type result object (- function-pointer-type))
  64
  65     OTHER-POINTER
  66     (load-type result object (- other-pointer-type))
  67
  68     DONE))
  69
  70
  71 (define-vop (function-subtype)
  72   (:translate function-subtype)
  73   (:policy :fast-safe)
  74   (:args (function :scs (descriptor-reg)))
  75   (:results (result :scs (unsigned-reg)))
  76   (:result-types positive-fixnum)
  77   (:generator 6
  78     (load-type result function (- vm:function-pointer-type))))
  79
  80 (define-vop (set-function-subtype)
  81   (:translate (setf function-subtype))
  82   (:policy :fast-safe)
  83   (:args (type :scs (unsigned-reg) :target result)
  84          (function :scs (descriptor-reg)))
  85   (:arg-types positive-fixnum *)
  86   (:results (result :scs (unsigned-reg)))
  87   (:result-types positive-fixnum)
  88   (:generator 6
  89     ;; Sparc is big-endian, and the type bits are in the least
  90     ;; significant byte of the word, which means the type bits are at
  91     ;; the highest byte.
  92     (inst stb type function (- (- vm:word-bytes 1) function-pointer-type))
  93     (move result type)))
  94
  95 (define-vop (get-header-data)
  96   (:translate get-header-data)
  97   (:policy :fast-safe)
  98   (:args (x :scs (descriptor-reg)))
  99   (:results (res :scs (unsigned-reg)))
 100   (:result-types positive-fixnum)
 101   (:generator 6
 102     (loadw res x 0 vm:other-pointer-type)
 103     (inst srln res res vm:type-bits)))
 104
 105 (define-vop (get-closure-length)
 106   (:translate get-closure-length)
 107   (:policy :fast-safe)
 108   (:args (x :scs (descriptor-reg)))
 109   (:results (res :scs (unsigned-reg)))
 110   (:result-types positive-fixnum)
 111   (:generator 6
 112     (loadw res x 0 vm:function-pointer-type)
 113     (inst srln res res vm:type-bits)))
 114
 115 (define-vop (set-header-data)
 116   (:translate set-header-data)
 117   (:policy :fast-safe)
 118   (:args (x :scs (descriptor-reg) :target res)
 119          (data :scs (any-reg immediate zero)))
 120   (:arg-types * positive-fixnum)
 121   (:results (res :scs (descriptor-reg)))
 122   (:temporary (:scs (non-descriptor-reg)) t1 t2)
 123   (:generator 6
 124     (loadw t1 x 0 vm:other-pointer-type)
 125     (inst and t1 vm:type-mask)
 126     (sc-case data
 127       (any-reg
 128        (inst slln t2 data (- vm:type-bits vm:fixnum-tag-bits))
 129        (inst or t1 t2))
 130       (immediate
 131        (inst or t1 (ash (tn-value data) vm:type-bits)))
 132       (zero))
 133     (storew t1 x 0 vm:other-pointer-type)
 134     (move res x)))
 135
 136
 137 (define-vop (make-fixnum)
 138   (:args (ptr :scs (any-reg descriptor-reg)))
 139   (:results (res :scs (any-reg descriptor-reg)))
 140   (:generator 1
 141     ;;
 142     ;; Some code (the hash table code) depends on this returning a
 143     ;; positive number so make sure it does.
 144     (inst slln res ptr vm:lowtag-bits)
 145     (inst srln res res 1)))
 146
 147 (define-vop (make-other-immediate-type)
 148   (:args (val :scs (any-reg descriptor-reg))
 149          (type :scs (any-reg descriptor-reg immediate)
 150                :target temp))
 151   (:results (res :scs (any-reg descriptor-reg)))
 152   (:temporary (:scs (non-descriptor-reg)) temp)
 153   (:generator 2
 154     (sc-case type
 155       (immediate
 156        (inst slln temp val vm:type-bits)
 157        (inst or res temp (tn-value type)))
 158       (t
 159        (inst sran temp type vm:fixnum-tag-bits)
 160        (inst slln res val (- vm:type-bits vm:fixnum-tag-bits))
 161        (inst or res res temp)))))
 162
 163 \f
 164 ;;;; Allocation
 165
 166 (define-vop (dynamic-space-free-pointer)
 167   (:results (int :scs (sap-reg)))
 168   (:result-types system-area-pointer)
 169   (:translate dynamic-space-free-pointer)
 170   (:policy :fast-safe)
 171   (:generator 1
 172     (move int alloc-tn)))
 173
 174 (define-vop (binding-stack-pointer-sap)
 175   (:results (int :scs (sap-reg)))
 176   (:result-types system-area-pointer)
 177   (:translate binding-stack-pointer-sap)
 178   (:policy :fast-safe)
 179   (:generator 1
 180     (move int bsp-tn)))
 181
 182 (define-vop (control-stack-pointer-sap)
 183   (:results (int :scs (sap-reg)))
 184   (:result-types system-area-pointer)
 185   (:translate control-stack-pointer-sap)
 186   (:policy :fast-safe)
 187   (:generator 1
 188     (move int csp-tn)))
 189
 190 \f
 191 ;;;; Code object frobbing.
 192
 193 (define-vop (code-instructions)
 194   (:translate code-instructions)
 195   (:policy :fast-safe)
 196   (:args (code :scs (descriptor-reg)))
 197   (:temporary (:scs (non-descriptor-reg)) ndescr)
 198   (:results (sap :scs (sap-reg)))
 199   (:result-types system-area-pointer)
 200   (:generator 10
 201     (loadw ndescr code 0 vm:other-pointer-type)
 202     (inst srln ndescr vm:type-bits)
 203     (inst slln ndescr vm:word-shift)
 204     (inst sub ndescr vm:other-pointer-type)
 205     (inst add sap code ndescr)))
 206
 207 (define-vop (compute-function)
 208   (:args (code :scs (descriptor-reg))
 209          (offset :scs (signed-reg unsigned-reg)))
 210   (:arg-types * positive-fixnum)
 211   (:results (func :scs (descriptor-reg)))
 212   (:temporary (:scs (non-descriptor-reg)) ndescr)
 213   (:generator 10
 214     (loadw ndescr code 0 vm:other-pointer-type)
 215     (inst srln ndescr vm:type-bits)
 216     (inst slln ndescr vm:word-shift)
 217     (inst add ndescr offset)
 218     (inst add ndescr (- vm:function-pointer-type vm:other-pointer-type))
 219     (inst add func code ndescr)))
 220
 221
 222 \f
 223 ;;;; Other random VOPs.
 224
 225
 226 (defknown unix::do-pending-interrupt () (values))
 227 (define-vop (unix::do-pending-interrupt)
 228   (:policy :fast-safe)
 229   (:translate unix::do-pending-interrupt)
 230   (:generator 1
 231     (inst unimp pending-interrupt-trap)))
 232
 233
 234 (define-vop (halt)
 235   (:generator 1
 236     (inst unimp halt-trap)))
 237
 238
 239 \f
 240 ;;;; Dynamic vop count collection support
 241
 242 (define-vop (count-me)
 243   (:args (count-vector :scs (descriptor-reg)))
 244   (:info index)
 245   (:temporary (:scs (non-descriptor-reg)) count)
 246   (:generator 1
 247     (let ((offset
 248            (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
 249       (assert (typep offset '(signed-byte 13)))
 250       (inst ldn count count-vector offset)
 251       (inst add count 1)
 252       (inst stn count count-vector offset))))
 253
 254 ;; The RDTICK instruction on Sparc V9s allows access to a 63-bit cycle
 255 ;; counter.
 256
 257 (defknown read-cycle-counter ()
 258   (values (unsigned-byte 32) (unsigned-byte 32)))
 259
 260 ;; Note: This should probably really only be used sparc-v8plus because
 261 ;; the tick counter is returned in a 64-bit register.
 262 (define-vop (read-cycle-counter)
 263   (:translate read-cycle-counter)
 264   (:guard (backend-featurep :sparc-v9))
 265   (:args)
 266   (:policy :fast-safe)
 267   (:results (lo :scs (unsigned-reg))
 268             (hi :scs (unsigned-reg)))
 269   (:result-types unsigned-num unsigned-num)
 270   ;; The temporary can be any of the 64-bit non-descriptor regs.  It
 271   ;; can't be any non-descriptor reg because they might not get saved
 272   ;; on a task switch, since we're still a 32-bit app.  Arbitrarily
 273   ;; select nl5.
 274   (:temporary (:sc unsigned-reg :offset nl5-offset) tick)
 275   (:generator 3
 276     (inst rdtick tick)
 277     ;; Get the hi and low parts of the counter into the results.
 278     (inst srlx hi tick 32)
 279     (inst clruw lo tick)))
 280
 281 #+sparc-v9
 282 (defun read-cycle-counter ()
 283   _N"Read the instruction cycle counter available on UltraSparcs.  The
 284 64-bit counter is returned as two 32-bit unsigned integers.  The low 32-bit
 285 result is the first value."
 286   (read-cycle-counter))
 287
 288 (defmacro with-cycle-counter (&body body)
 289   "Returns the primary value of BODY as the primary value, and the
 290  number of CPU cycles elapsed as secondary value."
 291   (let ((hi0 (gensym))
 292         (hi1 (gensym))
 293         (lo0 (gensym))
 294         (lo1 (gensym)))
 295     `(multiple-value-bind (,lo0 ,hi0)
 296          (read-cycle-counter)
 297        (values (locally ,@body)
 298                (multiple-value-bind (,lo1 ,hi1)
 299                    (read-cycle-counter)
 300                  ;; Can't do anything about the notes about generic
 301                  ;; arithmetic, so silence the notes..
 302                  (declare (optimize (inhibit-warnings 3)))
 303                  (+ (ash (- ,hi1 ,hi0) 32)
 304                     (- ,lo1 ,lo0)))))))