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))
 278
 279 (defmacro with-cycle-counter (&body body)
 280   "Returns the primary value of BODY as the primary value, and the
 281  number of tick cycles elapsed as secondary value.  To get the number
 282  of cycles, multiply by *cycles-per-tick*"
 283   (let ((hi0 (gensym))
 284         (hi1 (gensym))
 285         (lo0 (gensym))
 286         (lo1 (gensym)))
 287     `(multiple-value-bind (,lo0 ,hi0)
 288          (read-cycle-counter)
 289        (values (locally ,@body)
 290                (multiple-value-bind (,lo1 ,hi1)
 291                    (read-cycle-counter)
 292                  ;; Can't do anything about the notes about generic
 293                  ;; arithmetic, so silence the notes..
 294                  (declare (optimize (inhibit-warnings 3))
 295                  (+ (ash (- ,hi1 ,hi0) 32)
 296                     (- ,lo1 ,lo0)))))))