src/compiler/ppc/system.lisp

   1 ;;; -*- Package: PPC -*-
   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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
   7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
   8 ;;;
   9 (ext:file-comment
  10   "$Header: src/compiler/ppc/system.lisp $")
  11 ;;;
  12 ;;; **********************************************************************
  13 ;;;
  14 ;;;    PPC VM definitions of various system hacking operations.
  15 ;;;
  16 ;;; Written by Rob MacLachlan
  17 ;;;
  18 ;;; Mips conversion by William Lott and Christopher Hoover.
  19 ;;;
  20 (in-package "PPC")
  21
  22
  23 \f
  24 ;;;; Type frobbing VOPs
  25
  26 (define-vop (get-lowtag)
  27   (:translate get-lowtag)
  28   (:policy :fast-safe)
  29   (:args (object :scs (any-reg descriptor-reg)))
  30   (:results (result :scs (unsigned-reg)))
  31   (:result-types positive-fixnum)
  32   (:generator 1
  33     (inst andi. result object vm:lowtag-mask)))
  34
  35 (define-vop (get-type)
  36   (:translate get-type)
  37   (:policy :fast-safe)
  38   (:args (object :scs (descriptor-reg) :to (:eval 1)))
  39   (:results (result :scs (unsigned-reg) :from (:eval 0)))
  40   (:result-types positive-fixnum)
  41   (:generator 6
  42     ;; Grab the lowtag.
  43     (inst andi. result object lowtag-mask)
  44     ;; Check for various pointer types.
  45     (inst cmpwi result list-pointer-type)
  46     (inst beq done)
  47     (inst cmpwi result other-pointer-type)
  48     (inst beq other-pointer)
  49     (inst cmpwi result function-pointer-type)
  50     (inst beq function-pointer)
  51     (inst cmpwi result instance-pointer-type)
  52     (inst beq done)
  53     ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
  54     ;; we want the low 8 bits.
  55     (inst andi. result object #b11)
  56     (inst beq done)
  57     ;; It wasn't a fixnum, so get the low 8 bits.
  58     (inst andi. result object type-mask)
  59     (inst b done)
  60
  61     FUNCTION-POINTER
  62     (load-type result object (- function-pointer-type))
  63     (inst b done)
  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     (inst stb type function (- 3 function-pointer-type))
  90     (move result type)))
  91
  92 (define-vop (get-header-data)
  93   (:translate get-header-data)
  94   (:policy :fast-safe)
  95   (:args (x :scs (descriptor-reg)))
  96   (:results (res :scs (unsigned-reg)))
  97   (:result-types positive-fixnum)
  98   (:generator 6
  99     (loadw res x 0 vm:other-pointer-type)
 100     (inst srwi res res vm:type-bits)))
 101
 102 (define-vop (get-closure-length)
 103   (:translate get-closure-length)
 104   (:policy :fast-safe)
 105   (:args (x :scs (descriptor-reg)))
 106   (:results (res :scs (unsigned-reg)))
 107   (:result-types positive-fixnum)
 108   (:generator 6
 109     (loadw res x 0 vm:function-pointer-type)
 110     (inst srwi res res vm:type-bits)))
 111
 112 (define-vop (set-header-data)
 113   (:translate set-header-data)
 114   (:policy :fast-safe)
 115   (:args (x :scs (descriptor-reg) :target res)
 116          (data :scs (any-reg immediate zero)))
 117   (:arg-types * positive-fixnum)
 118   (:results (res :scs (descriptor-reg)))
 119   (:temporary (:scs (non-descriptor-reg)) t1 t2)
 120   (:generator 6
 121     (loadw t1 x 0 vm:other-pointer-type)
 122     (inst andi. t1 t1 vm:type-mask)
 123     (sc-case data
 124       (any-reg
 125        (inst slwi t2 data (- vm:type-bits 2))
 126        (inst or t1 t1 t2))
 127       (immediate
 128        (inst ori t1 t1 (ash (tn-value data) vm:type-bits)))
 129       (zero))
 130     (storew t1 x 0 vm:other-pointer-type)
 131     (move res x)))
 132
 133
 134 (define-vop (make-fixnum)
 135   (:args (ptr :scs (any-reg descriptor-reg)))
 136   (:results (res :scs (any-reg descriptor-reg)))
 137   (:generator 1
 138     ;;
 139     ;; Some code (the hash table code) depends on this returning a
 140     ;; positive number so make sure it does.
 141     (inst slwi res ptr 3)
 142     (inst srwi res res 1)))
 143
 144 (define-vop (make-other-immediate-type)
 145   (:args (val :scs (any-reg descriptor-reg))
 146          (type :scs (any-reg descriptor-reg immediate)
 147                :target temp))
 148   (:results (res :scs (any-reg descriptor-reg)))
 149   (:temporary (:scs (non-descriptor-reg)) temp)
 150   (:generator 2
 151     (sc-case type
 152       (immediate
 153        (inst slwi temp val vm:type-bits)
 154        (inst ori res temp (tn-value type)))
 155       (t
 156        (inst srawi temp type 2)
 157        (inst slwi res val (- vm:type-bits 2))
 158        (inst or res res temp)))))
 159
 160 \f
 161 ;;;; Allocation
 162
 163 (define-vop (dynamic-space-free-pointer)
 164   (:results (int :scs (sap-reg)))
 165   (:result-types system-area-pointer)
 166   (:translate dynamic-space-free-pointer)
 167   (:policy :fast-safe)
 168   (:generator 1
 169     (move int alloc-tn)))
 170
 171 (define-vop (binding-stack-pointer-sap)
 172   (:results (int :scs (sap-reg)))
 173   (:result-types system-area-pointer)
 174   (:translate binding-stack-pointer-sap)
 175   (:policy :fast-safe)
 176   (:generator 1
 177     (move int bsp-tn)))
 178
 179 (define-vop (control-stack-pointer-sap)
 180   (:results (int :scs (sap-reg)))
 181   (:result-types system-area-pointer)
 182   (:translate control-stack-pointer-sap)
 183   (:policy :fast-safe)
 184   (:generator 1
 185     (move int csp-tn)))
 186
 187 \f
 188 ;;;; Code object frobbing.
 189
 190 (define-vop (code-instructions)
 191   (:translate code-instructions)
 192   (:policy :fast-safe)
 193   (:args (code :scs (descriptor-reg)))
 194   (:temporary (:scs (non-descriptor-reg)) ndescr)
 195   (:results (sap :scs (sap-reg)))
 196   (:result-types system-area-pointer)
 197   (:generator 10
 198     (loadw ndescr code 0 vm:other-pointer-type)
 199     (inst srwi ndescr ndescr vm:type-bits)
 200     (inst slwi ndescr ndescr vm:word-shift)
 201     (inst subi ndescr ndescr vm:other-pointer-type)
 202     (inst add sap code ndescr)))
 203
 204 (define-vop (compute-function)
 205   (:args (code :scs (descriptor-reg))
 206          (offset :scs (signed-reg unsigned-reg)))
 207   (:arg-types * positive-fixnum)
 208   (:results (func :scs (descriptor-reg)))
 209   (:temporary (:scs (non-descriptor-reg)) ndescr)
 210   (:generator 10
 211     (loadw ndescr code 0 vm:other-pointer-type)
 212     (inst srwi ndescr ndescr vm:type-bits)
 213     (inst slwi ndescr ndescr vm:word-shift)
 214     (inst add ndescr ndescr offset)
 215     (inst addi ndescr ndescr (- vm:function-pointer-type vm:other-pointer-type))
 216     (inst add func code ndescr)))
 217
 218
 219 \f
 220 ;;;; Other random VOPs.
 221
 222
 223 (defknown unix::do-pending-interrupt () (values))
 224 (define-vop (unix::do-pending-interrupt)
 225   (:policy :fast-safe)
 226   (:translate unix::do-pending-interrupt)
 227   (:generator 1
 228     (inst unimp pending-interrupt-trap)))
 229
 230
 231 (define-vop (halt)
 232   (:generator 1
 233     (inst unimp halt-trap)))
 234
 235
 236 \f
 237 ;;;; Dynamic vop count collection support
 238
 239 (define-vop (count-me)
 240   (:args (count-vector :scs (descriptor-reg)))
 241   (:info index)
 242   (:temporary (:scs (non-descriptor-reg)) count)
 243   (:generator 1
 244     (let ((offset
 245            (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
 246       (assert (typep offset '(signed-byte 16)))
 247       (inst lwz count count-vector offset)
 248       (inst addi count count 1)
 249       (inst stw count count-vector offset))))
 250 \f
 251 (defknown read-time-base ()
 252   (values (unsigned-byte 32) (unsigned-byte 32)))
 253
 254 (define-vop (read-time-base)
 255   (:translate read-time-base)
 256   (:args)
 257   (:policy :fast-safe)
 258   (:results (lo :scs (unsigned-reg))
 259             (hi :scs (unsigned-reg)))
 260   (:result-types unsigned-num unsigned-num)
 261   (:temporary (:sc unsigned-reg) temp)
 262   (:temporary (:sc unsigned-reg :target hi) temp-hi)
 263   (:temporary (:sc unsigned-reg :target lo) temp-lo)
 264   (:generator 7
 265     ;; From 2.2.1
 266     (let ((loop (gen-label)))
 267       (emit-label loop)
 268       (inst mftbu temp-hi)
 269       (inst mftb temp-lo)
 270       (inst mftbu temp)
 271       (inst cmpw temp temp-hi)
 272       (inst bne loop)
 273       (move hi temp-hi)
 274       (move lo temp-lo))))
 275
 276 (defun read-cycle-counter ()
 277   (read-time-base))