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 (pointer-hash)
 109   (:translate pointer-hash)
 110   (:args (ptr :scs (any-reg descriptor-reg)))
 111   (:results (res :scs (any-reg descriptor-reg)))
 112   (:policy :fast-safe)
 113   (:generator 1
 114     ;; FIXME: It would be better if this would mask the lowtag,
 115     ;; and shift the result into a positive fixnum like on x86.
 116     (inst zdep ptr 29 29 res)))
 117
 118 (define-vop (make-other-immediate-type)
 119   (:args (val :scs (any-reg descriptor-reg))
 120          (type :scs (any-reg descriptor-reg) :target temp))
 121   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
 122   (:temporary (:scs (non-descriptor-reg)) temp)
 123   (:generator 2
 124     (inst sll val (- n-widetag-bits 2) res)
 125     (inst sra type 2 temp)
 126     (inst or res temp res)))
 127
 128 \f
 129 ;;;; Allocation
 130
 131 (define-vop (dynamic-space-free-pointer)
 132   (:results (int :scs (sap-reg)))
 133   (:result-types system-area-pointer)
 134   (:translate dynamic-space-free-pointer)
 135   (:policy :fast-safe)
 136   (:generator 1
 137     (move alloc-tn int)))
 138
 139 (define-vop (binding-stack-pointer-sap)
 140   (:results (int :scs (sap-reg)))
 141   (:result-types system-area-pointer)
 142   (:translate binding-stack-pointer-sap)
 143   (:policy :fast-safe)
 144   (:generator 1
 145     (move bsp-tn int)))
 146
 147 (define-vop (control-stack-pointer-sap)
 148   (:results (int :scs (sap-reg)))
 149   (:result-types system-area-pointer)
 150   (:translate control-stack-pointer-sap)
 151   (:policy :fast-safe)
 152   (:generator 1
 153     (move csp-tn int)))
 154
 155 \f
 156 ;;;; Code object frobbing.
 157
 158 (define-vop (code-instructions)
 159   (:translate code-instructions)
 160   (:policy :fast-safe)
 161   (:args (code :scs (descriptor-reg)))
 162   (:temporary (:scs (non-descriptor-reg)) ndescr)
 163   (:results (sap :scs (sap-reg)))
 164   (:result-types system-area-pointer)
 165   (:generator 10
 166     (loadw ndescr code 0 other-pointer-lowtag)
 167     (inst srl ndescr 8 ndescr)
 168     (inst sll ndescr 2 ndescr)
 169     (inst addi (- other-pointer-lowtag) ndescr ndescr)
 170     (inst add code ndescr sap)))
 171
 172 (define-vop (compute-fun)
 173   (:args (code :scs (descriptor-reg))
 174          (offset :scs (signed-reg unsigned-reg)))
 175   (:arg-types * positive-fixnum)
 176   (:results (func :scs (descriptor-reg)))
 177   (:temporary (:scs (non-descriptor-reg)) ndescr)
 178   (:generator 10
 179     (loadw ndescr code 0 other-pointer-lowtag)
 180     (inst srl ndescr 8 ndescr)
 181     (inst sll ndescr 2 ndescr)
 182     (inst add ndescr offset ndescr)
 183     (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
 184     (inst add ndescr code func)))
 185
 186 \f
 187 ;;;; Other random VOPs.
 188
 189
 190 (defknown sb!unix::receive-pending-interrupt () (values))
 191 (define-vop (sb!unix::receive-pending-interrupt)
 192   (:policy :fast-safe)
 193   (:translate sb!unix::receive-pending-interrupt)
 194   (:generator 1
 195     (inst break pending-interrupt-trap)))
 196
 197
 198 (define-vop (halt)
 199   (:generator 1
 200     (inst break halt-trap)))
 201
 202 #+hpux
 203 (define-vop (setup-return-from-lisp-stub)
 204   (:results)
 205   (:save-p t)
 206   (:temporary (:sc any-reg :offset nl0-offset) nl0)
 207   (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
 208   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 209   (:temporary (:scs (non-descriptor-reg)) temp)
 210   (:vop-var vop)
 211   (:generator 100
 212     (let ((stub (make-fixup 'return-from-lisp-stub :assembly-routine)))
 213       (inst li stub nl0))
 214     (let ((cur-nfp (current-nfp-tn vop)))
 215       (when cur-nfp
 216         (store-stack-tn nfp-save cur-nfp))
 217       (inst li (make-fixup "setup_return_from_lisp_stub" :foreign) cfunc)
 218       (let ((fixup (make-fixup "call_into_c" :foreign)))
 219         (inst ldil fixup temp)
 220         (inst ble fixup c-text-space temp))
 221       (inst addi  64 nsp-tn nsp-tn)
 222       (inst addi -64 nsp-tn nsp-tn)
 223       (when cur-nfp
 224         (load-stack-tn cur-nfp nfp-save)))))
 225 \f
 226 ;;;; Dynamic vop count collection support
 227
 228 (define-vop (count-me)
 229   (:args (count-vector :scs (descriptor-reg)))
 230   (:info index)
 231   (:temporary (:scs (non-descriptor-reg)) count)
 232   (:generator 1
 233     (let ((offset
 234            (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
 235       (inst ldw offset count-vector count)
 236       (inst addi 1 count count)
 237       (inst stw count offset count-vector))))
 238