src/compiler/mips/system.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Random pointer comparison VOPs
   5
   6 (define-vop (pointer-compare)
   7   (:args (x :scs (sap-reg))
   8          (y :scs (sap-reg)))
   9   (:arg-types system-area-pointer system-area-pointer)
  10   (:temporary (:scs (non-descriptor-reg)) temp)
  11   (:conditional)
  12   (:info target not-p)
  13   (:policy :fast-safe)
  14   (:note "inline comparison")
  15   (:variant-vars condition)
  16   (:generator 3
  17     (three-way-comparison x y condition :unsigned not-p target temp)))
  18
  19 #+nil
  20 (macrolet ((frob (name cond)
  21              `(progn
  22                 (def-primitive-translator ,name (x y) `(,',name ,x ,y))
  23                 (defknown ,name (t t) boolean (movable foldable flushable))
  24                 (define-vop (,name pointer-compare)
  25                   (:translate ,name)
  26                   (:variant ,cond)))))
  27   (frob pointer< :lt)
  28   (frob pointer> :gt))
  29
  30
  31 \f
  32 ;;;; Type frobbing VOPs
  33
  34 (define-vop (lowtag-of)
  35   (:translate lowtag-of)
  36   (:policy :fast-safe)
  37   (:args (object :scs (any-reg descriptor-reg)))
  38   (:results (result :scs (unsigned-reg)))
  39   (:result-types positive-fixnum)
  40   (:generator 1
  41     (inst and result object lowtag-mask)))
  42
  43 (define-vop (widetag-of)
  44   (:translate widetag-of)
  45   (:policy :fast-safe)
  46   (:args (object :scs (descriptor-reg)))
  47   (:temporary (:scs (non-descriptor-reg)) ndescr)
  48   (:results (result :scs (unsigned-reg)))
  49   (:result-types positive-fixnum)
  50   (:generator 6
  51     ;; Pick off objects with headers.
  52     (inst and ndescr object lowtag-mask)
  53     (inst xor ndescr other-pointer-lowtag)
  54     (inst beq ndescr other-ptr)
  55     (inst xor ndescr (logxor other-pointer-lowtag fun-pointer-lowtag))
  56     (inst beq ndescr function-ptr)
  57
  58     ;; Pick off fixnums.
  59     (inst and result object 3)
  60     (inst beq result done)
  61
  62     ;; Pick off structure and list pointers.
  63     (inst and result object 1)
  64     (inst bne result lowtag-only)
  65     (inst nop)
  66
  67       ;; Must be an other immediate.
  68     (inst b done)
  69     (inst and result object widetag-mask)
  70
  71     FUNCTION-PTR
  72     (load-type result object (- fun-pointer-lowtag))
  73     (inst b done)
  74     (inst nop)
  75
  76     LOWTAG-ONLY
  77     (inst b done)
  78     (inst and result object lowtag-mask)
  79
  80     OTHER-PTR
  81     (load-type result object (- other-pointer-lowtag))
  82     (inst nop)
  83
  84     DONE))
  85
  86 (define-vop (fun-subtype)
  87   (:translate fun-subtype)
  88   (:policy :fast-safe)
  89   (:args (function :scs (descriptor-reg)))
  90   (:results (result :scs (unsigned-reg)))
  91   (:result-types positive-fixnum)
  92   (:generator 6
  93     (load-type result function (- fun-pointer-lowtag))
  94     (inst nop)))
  95
  96 (define-vop (set-fun-subtype)
  97   (:translate (setf fun-subtype))
  98   (:policy :fast-safe)
  99   (:args (type :scs (unsigned-reg) :target result)
 100          (function :scs (descriptor-reg)))
 101   (:arg-types positive-fixnum *)
 102   (:results (result :scs (unsigned-reg)))
 103   (:result-types positive-fixnum)
 104   (:generator 6
 105     (inst sb type function (- fun-pointer-lowtag))
 106     (move result type)))
 107
 108
 109 (define-vop (get-header-data)
 110   (:translate get-header-data)
 111   (:policy :fast-safe)
 112   (:args (x :scs (descriptor-reg)))
 113   (:results (res :scs (unsigned-reg)))
 114   (:result-types positive-fixnum)
 115   (:generator 6
 116     (loadw res x 0 other-pointer-lowtag)
 117     (inst srl res res n-widetag-bits)))
 118
 119 (define-vop (get-closure-length)
 120   (:translate get-closure-length)
 121   (:policy :fast-safe)
 122   (:args (x :scs (descriptor-reg)))
 123   (:results (res :scs (unsigned-reg)))
 124   (:result-types positive-fixnum)
 125   (:generator 6
 126     (loadw res x 0 fun-pointer-lowtag)
 127     (inst srl res res n-widetag-bits)))
 128
 129 (define-vop (set-header-data)
 130   (:translate set-header-data)
 131   (:policy :fast-safe)
 132   (:args (x :scs (descriptor-reg) :target res)
 133          (data :scs (any-reg immediate zero)))
 134   (:arg-types * positive-fixnum)
 135   (:results (res :scs (descriptor-reg)))
 136   (:temporary (:scs (non-descriptor-reg)) t1 t2)
 137   (:generator 6
 138     (loadw t1 x 0 other-pointer-lowtag)
 139     (inst and t1 widetag-mask)
 140     (sc-case data
 141       (any-reg
 142        (inst sll t2 data (- n-widetag-bits 2))
 143        (inst or t1 t2))
 144       (immediate
 145        (inst or t1 (ash (tn-value data) n-widetag-bits)))
 146       (zero))
 147     (storew t1 x 0 other-pointer-lowtag)
 148     (move res x)))
 149
 150 (define-vop (make-fixnum)
 151   (:args (ptr :scs (any-reg descriptor-reg)))
 152   (:results (res :scs (any-reg descriptor-reg)))
 153   (:generator 1
 154     ;;
 155     ;; Some code (the hash table code) depends on this returning a
 156     ;; positive number so make sure it does.
 157     (inst sll res ptr 3)
 158     (inst srl res res 1)))
 159
 160 (define-vop (make-other-immediate-type)
 161   (:args (val :scs (any-reg descriptor-reg))
 162          (type :scs (any-reg descriptor-reg immediate)
 163                :target temp))
 164   (:results (res :scs (any-reg descriptor-reg)))
 165   (:temporary (:scs (non-descriptor-reg)) temp)
 166   (:generator 2
 167     (sc-case type
 168       ((immediate)
 169        (inst sll temp val n-widetag-bits)
 170        (inst or res temp (tn-value type)))
 171       (t
 172        (inst sra temp type 2)
 173        (inst sll res val (- n-widetag-bits 2))
 174        (inst or res res temp)))))
 175
 176 \f
 177 ;;;; Allocation
 178
 179 (define-vop (dynamic-space-free-pointer)
 180   (:results (int :scs (sap-reg)))
 181   (:result-types system-area-pointer)
 182   (:translate dynamic-space-free-pointer)
 183   (:policy :fast-safe)
 184   (:generator 1
 185     (move int alloc-tn)))
 186
 187 (define-vop (binding-stack-pointer-sap)
 188   (:results (int :scs (sap-reg)))
 189   (:result-types system-area-pointer)
 190   (:translate binding-stack-pointer-sap)
 191   (:policy :fast-safe)
 192   (:generator 1
 193     (move int bsp-tn)))
 194
 195 (define-vop (control-stack-pointer-sap)
 196   (:results (int :scs (sap-reg)))
 197   (:result-types system-area-pointer)
 198   (:translate control-stack-pointer-sap)
 199   (:policy :fast-safe)
 200   (:generator 1
 201     (move int csp-tn)))
 202
 203 \f
 204 ;;;; Code object frobbing.
 205
 206 (define-vop (code-instructions)
 207   (:translate code-instructions)
 208   (:policy :fast-safe)
 209   (:args (code :scs (descriptor-reg)))
 210   (:temporary (:scs (non-descriptor-reg)) ndescr)
 211   (:results (sap :scs (sap-reg)))
 212   (:result-types system-area-pointer)
 213   (:generator 10
 214     (loadw ndescr code 0 other-pointer-lowtag)
 215     (inst srl ndescr n-widetag-bits)
 216     (inst sll ndescr word-shift)
 217     (inst subu ndescr other-pointer-lowtag)
 218     (inst addu sap code ndescr)))
 219
 220 (define-vop (compute-fun)
 221   (:args (code :scs (descriptor-reg))
 222          (offset :scs (signed-reg unsigned-reg)))
 223   (:arg-types * positive-fixnum)
 224   (:results (func :scs (descriptor-reg)))
 225   (:temporary (:scs (non-descriptor-reg)) ndescr)
 226   (:generator 10
 227     (loadw ndescr code 0 other-pointer-lowtag)
 228     (inst srl ndescr n-widetag-bits)
 229     (inst sll ndescr word-shift)
 230     (inst addu ndescr offset)
 231     (inst addu ndescr (- fun-pointer-lowtag other-pointer-lowtag))
 232     (inst addu func code ndescr)))
 233
 234 \f
 235 ;;;; Other random VOPs.
 236
 237
 238 (defknown sb!unix::receive-pending-interrupt () (values))
 239 (define-vop (sb!unix::receive-pending-interrupt)
 240   (:policy :fast-safe)
 241   (:translate sb!unix::receive-pending-interrupt)
 242   (:generator 1
 243     (inst break pending-interrupt-trap)))
 244
 245
 246 (define-vop (halt)
 247   (:generator 1
 248     (inst break halt-trap)))
 249
 250 \f
 251 ;;;; Dynamic vop count collection support
 252
 253 (define-vop (count-me)
 254   (:args (count-vector :scs (descriptor-reg)))
 255   (:info index)
 256   (:temporary (:scs (non-descriptor-reg)) count)
 257   (:generator 1
 258     (let ((offset
 259            (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
 260       (inst lw count count-vector offset)
 261       (inst nop)
 262       (inst addu count 1)
 263       (inst sw count count-vector offset))))