src/compiler/hppa/system.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Type frobbing VOPs
   5
   6 (define-vop (lowtag-of)
   7   (:translate lowtag-of)
   8   (:policy :fast-safe)
   9   (:args (object :scs (any-reg descriptor-reg) :target result))
  10   (:results (result :scs (unsigned-reg)))
  11   (:result-types positive-fixnum)
  12   (:generator 1
  13     (inst extru object 31 3 result)))
  14
  15 (define-vop (widetag-of)
  16   (:translate widetag-of)
  17   (:policy :fast-safe)
  18   (:args (object :scs (descriptor-reg) :to (:eval 1)))
  19   (:results (result :scs (unsigned-reg) :from (:eval 0)))
  20   (:result-types positive-fixnum)
  21   (:generator 6
  22     (inst extru object 31 3 result)
  23     (inst comib := other-pointer-lowtag result other-ptr :nullify t)
  24     (inst comib := fun-pointer-lowtag result function-ptr :nullify t)
  25     (inst bb t object 31 done :nullify t)
  26     (inst extru object 31 2 result :=)
  27     (inst extru object 31 8 result)
  28     (inst nop :tr)
  29
  30     FUNCTION-PTR
  31     (load-type result object (- fun-pointer-lowtag))
  32     (inst nop :tr)
  33
  34     OTHER-PTR
  35     (load-type result object (- other-pointer-lowtag))
  36
  37     DONE))
  38
  39 (define-vop (fun-subtype)
  40   (:translate fun-subtype)
  41   (:policy :fast-safe)
  42   (:args (function :scs (descriptor-reg)))
  43   (:results (result :scs (unsigned-reg)))
  44   (:result-types positive-fixnum)
  45   (:generator 6
  46     (load-type result function (- fun-pointer-lowtag))))
  47
  48 (define-vop (set-fun-subtype)
  49   (:translate (setf fun-subtype))
  50   (:policy :fast-safe)
  51   (:args (type :scs (unsigned-reg) :target result)
  52          (function :scs (descriptor-reg)))
  53   (:arg-types positive-fixnum *)
  54   (:results (result :scs (unsigned-reg)))
  55   (:result-types positive-fixnum)
  56   (:generator 6
  57     (inst stb type (- 3 fun-pointer-lowtag) function)
  58     (move type result)))
  59
  60 (define-vop (get-header-data)
  61   (:translate get-header-data)
  62   (:policy :fast-safe)
  63   (:args (x :scs (descriptor-reg)))
  64   (:results (res :scs (unsigned-reg)))
  65   (:result-types positive-fixnum)
  66   (:generator 6
  67     (loadw res x 0 other-pointer-lowtag)
  68     (inst srl res 8 res)))
  69
  70 (define-vop (get-closure-length)
  71   (:translate get-closure-length)
  72   (:policy :fast-safe)
  73   (:args (x :scs (descriptor-reg)))
  74   (:results (res :scs (unsigned-reg)))
  75   (:result-types positive-fixnum)
  76   (:generator 6
  77     (loadw res x 0 fun-pointer-lowtag)
  78     (inst srl res 8 res)))
  79
  80 (define-vop (set-header-data)
  81   (:translate set-header-data)
  82   (:policy :fast-safe)
  83   (:args (x :scs (descriptor-reg) :target res)
  84          (data :scs (unsigned-reg)))
  85   (:arg-types * positive-fixnum)
  86   (:results (res :scs (descriptor-reg)))
  87   (:temporary (:scs (non-descriptor-reg)) temp)
  88   (:generator 6
  89     (loadw temp x 0 other-pointer-lowtag)
  90     (inst dep data 23 24 temp)
  91     (storew temp x 0 other-pointer-lowtag)
  92     (move x res)))
  93
  94 (define-vop (set-header-data-c)
  95   (:translate set-header-data)
  96   (:policy :fast-safe)
  97   (:args (x :scs (descriptor-reg) :target res))
  98   (:arg-types * (:constant (signed-byte 5)))
  99   (:info data)
 100   (:results (res :scs (descriptor-reg)))
 101   (:temporary (:scs (non-descriptor-reg)) temp)
 102   (:generator 5
 103     (loadw temp x 0 other-pointer-lowtag)
 104     (inst dep data 23 24 temp)
 105     (storew temp x 0 other-pointer-lowtag)
 106     (move x res)))
 107
 108 (define-vop (make-fixnum)
 109   (:args (ptr :scs (any-reg descriptor-reg)))
 110   (:results (res :scs (any-reg descriptor-reg)))
 111   (:generator 1
 112     ;;
 113     ;; Some code (the hash table code) depends on this returning a
 114     ;; positive number so make sure it does.
 115     (inst zdep ptr 29 29 res)))
 116
 117 (define-vop (make-other-immediate-type)
 118   (:args (val :scs (any-reg descriptor-reg))
 119          (type :scs (any-reg descriptor-reg) :target temp))
 120   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
 121   (:temporary (:scs (non-descriptor-reg)) temp)
 122   (:generator 2
 123     (inst sll val (- n-widetag-bits 2) res)
 124     (inst sra type 2 temp)
 125     (inst or res temp res)))
 126
 127 \f
 128 ;;;; Allocation
 129
 130 (define-vop (dynamic-space-free-pointer)
 131   (:results (int :scs (sap-reg)))
 132   (:result-types system-area-pointer)
 133   (:translate dynamic-space-free-pointer)
 134   (:policy :fast-safe)
 135   (:generator 1
 136     (move alloc-tn int)))
 137
 138 (define-vop (binding-stack-pointer-sap)
 139   (:results (int :scs (sap-reg)))
 140   (:result-types system-area-pointer)
 141   (:translate binding-stack-pointer-sap)
 142   (:policy :fast-safe)
 143   (:generator 1
 144     (move bsp-tn int)))
 145
 146 (define-vop (control-stack-pointer-sap)
 147   (:results (int :scs (sap-reg)))
 148   (:result-types system-area-pointer)
 149   (:translate control-stack-pointer-sap)
 150   (:policy :fast-safe)
 151   (:generator 1
 152     (move csp-tn int)))
 153
 154 \f
 155 ;;;; Code object frobbing.
 156
 157 (define-vop (code-instructions)
 158   (:translate code-instructions)
 159   (:policy :fast-safe)
 160   (:args (code :scs (descriptor-reg)))
 161   (:temporary (:scs (non-descriptor-reg)) ndescr)
 162   (:results (sap :scs (sap-reg)))
 163   (:result-types system-area-pointer)
 164   (:generator 10
 165     (loadw ndescr code 0 other-pointer-lowtag)
 166     (inst srl ndescr 8 ndescr)
 167     (inst sll ndescr 2 ndescr)
 168     (inst addi (- other-pointer-lowtag) ndescr ndescr)
 169     (inst add code ndescr sap)))
 170
 171 (define-vop (compute-fun)
 172   (:args (code :scs (descriptor-reg))
 173          (offset :scs (signed-reg unsigned-reg)))
 174   (:arg-types * positive-fixnum)
 175   (:results (func :scs (descriptor-reg)))
 176   (:temporary (:scs (non-descriptor-reg)) ndescr)
 177   (:generator 10
 178     (loadw ndescr code 0 other-pointer-lowtag)
 179     (inst srl ndescr 8 ndescr)
 180     (inst sll ndescr 2 ndescr)
 181     (inst add ndescr offset ndescr)
 182     (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
 183     (inst add ndescr code func)))
 184
 185 \f
 186 ;;;; Other random VOPs.
 187
 188
 189 (defknown sb!unix::receive-pending-interrupt () (values))
 190 (define-vop (sb!unix::receive-pending-interrupt)
 191   (:policy :fast-safe)
 192   (:translate sb!unix::receive-pending-interrupt)
 193   (:generator 1
 194     (inst break pending-interrupt-trap)))
 195
 196
 197 (define-vop (halt)
 198   (:generator 1
 199     (inst break halt-trap)))
 200
 201 \f
 202 ;;;; Dynamic vop count collection support
 203
 204 (define-vop (count-me)
 205   (:args (count-vector :scs (descriptor-reg)))
 206   (:info index)
 207   (:temporary (:scs (non-descriptor-reg)) count)
 208   (:generator 1
 209     (let ((offset
 210            (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
 211       (inst ldw offset count-vector count)
 212       (inst addi 1 count count)
 213       (inst stw count offset count-vector))))