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))