src/compiler/hppa/system.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Type frobbing VOPs
   5
   6 ;FIX this vop got instruction-exploded after mips convert, look at old hppa
   7 (define-vop (widetag-of)
   8   (:translate widetag-of)
   9   (:policy :fast-safe)
  10   (:args (object :scs (descriptor-reg)))
  11   (:temporary (:scs (non-descriptor-reg)) temp1 temp2)
  12   (:results (result :scs (unsigned-reg)))
  13   (:result-types positive-fixnum)
  14   (:generator 6
  15     (inst li lowtag-mask temp1)
  16     (inst li other-pointer-lowtag temp2)
  17     (inst and temp1 object temp1)
  18     (inst xor temp1 temp2 temp1)
  19     (inst comb := temp1 zero-tn OTHER-PTR)
  20     (inst li (logxor other-pointer-lowtag fun-pointer-lowtag) temp2)
  21     (inst xor temp1 temp2 temp1)
  22     (inst comb := temp1 zero-tn FUNCTION-PTR)
  23     (inst li fixnum-tag-mask temp1)  ; pick off fixnums
  24     (inst li 1 temp2)
  25     (inst and temp1 object result)
  26     (inst comb := result zero-tn DONE)
  27
  28     (inst and object temp2 result)
  29     (inst comb :<> result zero-tn LOWTAG-ONLY :nullify t)
  30
  31     ;; must be an other immediate
  32     (inst li widetag-mask temp2)
  33     (inst b DONE)
  34     (inst and temp2 object result)
  35
  36     FUNCTION-PTR
  37     (load-type result object (- fun-pointer-lowtag))
  38     (inst b done :nullify t)
  39
  40     LOWTAG-ONLY
  41     (inst li lowtag-mask temp1)
  42     (inst b done)
  43     (inst and object temp1 result)
  44
  45     OTHER-PTR
  46     (load-type result object (- other-pointer-lowtag))
  47
  48     DONE))
  49
  50 (define-vop (%other-pointer-widetag)
  51   (:translate %other-pointer-widetag)
  52   (:policy :fast-safe)
  53   (:args (object :scs (descriptor-reg)))
  54   (:results (result :scs (unsigned-reg)))
  55   (:result-types positive-fixnum)
  56   (:generator 6
  57     (load-type result object (- other-pointer-lowtag))))
  58
  59 (define-vop (fun-subtype)
  60   (:translate fun-subtype)
  61   (:policy :fast-safe)
  62   (:args (function :scs (descriptor-reg)))
  63   (:results (result :scs (unsigned-reg)))
  64   (:result-types positive-fixnum)
  65   (:generator 6
  66     (load-type result function (- fun-pointer-lowtag))))
  67
  68 (define-vop (get-header-data)
  69   (:translate get-header-data)
  70   (:policy :fast-safe)
  71   (:args (x :scs (descriptor-reg)))
  72   (:results (res :scs (unsigned-reg)))
  73   (:result-types positive-fixnum)
  74   (:generator 6
  75     (loadw res x 0 other-pointer-lowtag)
  76     (inst srl res n-widetag-bits res)))
  77
  78 (define-vop (get-closure-length)
  79   (:translate get-closure-length)
  80   (:policy :fast-safe)
  81   (:args (x :scs (descriptor-reg)))
  82   (:results (res :scs (unsigned-reg)))
  83   (:result-types positive-fixnum)
  84   (:temporary (:sc non-descriptor-reg) temp)
  85   (:generator 6
  86     (loadw res x 0 fun-pointer-lowtag)
  87     (inst srl res n-widetag-bits res)
  88     (inst li short-header-max-words temp)
  89     (inst and res temp res)))
  90
  91 ;;; FIXME-lav, not sure we need data of type immediate and zero, test without,
  92 ;;; if so revert to old hppa code
  93 (define-vop (set-header-data)
  94   (:translate set-header-data)
  95   (:policy :fast-safe)
  96   (:args (x :scs (descriptor-reg) :target res)
  97          (data :scs (any-reg immediate zero)))
  98   (:arg-types * positive-fixnum)
  99   (:results (res :scs (descriptor-reg)))
 100   (:temporary (:scs (non-descriptor-reg)) t1 t2)
 101   (:generator 6
 102     (loadw t1 x 0 other-pointer-lowtag)
 103     ;; replace below 2 inst with: (mask widetag-mask t1 t1)
 104     (inst li widetag-mask t2)
 105     (inst and t1 t2 t1)
 106     (sc-case data
 107       (any-reg
 108         (inst sll data (- n-widetag-bits 2) t2)
 109         (inst or t1 t2 t1))
 110       (immediate
 111         (inst li (ash (tn-value data) n-widetag-bits) t2)
 112         (inst or t1 t2 t1))
 113       (zero))
 114
 115     (storew t1 x 0 other-pointer-lowtag)
 116     (move x res)))
 117
 118 (define-vop (pointer-hash)
 119   (:translate pointer-hash)
 120   (:args (ptr :scs (any-reg descriptor-reg)))
 121   (:results (res :scs (any-reg descriptor-reg)))
 122   (:policy :fast-safe)
 123   (:generator 1
 124     (inst zdep ptr n-positive-fixnum-bits n-positive-fixnum-bits res)))
 125 \f
 126 ;;;; Allocation
 127
 128 (define-vop (dynamic-space-free-pointer)
 129   (:results (int :scs (sap-reg)))
 130   (:result-types system-area-pointer)
 131   (:translate dynamic-space-free-pointer)
 132   (:policy :fast-safe)
 133   (:generator 1
 134     (move alloc-tn int)))
 135
 136 (define-vop (binding-stack-pointer-sap)
 137   (:results (int :scs (sap-reg)))
 138   (:result-types system-area-pointer)
 139   (:translate binding-stack-pointer-sap)
 140   (:policy :fast-safe)
 141   (:generator 1
 142     (move bsp-tn int)))
 143
 144 (define-vop (control-stack-pointer-sap)
 145   (:results (int :scs (sap-reg)))
 146   (:result-types system-area-pointer)
 147   (:translate control-stack-pointer-sap)
 148   (:policy :fast-safe)
 149   (:generator 1
 150     (move csp-tn int)))
 151
 152 \f
 153 ;;;; Code object frobbing.
 154
 155 (define-vop (code-instructions)
 156   (:translate code-instructions)
 157   (:policy :fast-safe)
 158   (:args (code :scs (descriptor-reg)))
 159   (:temporary (:scs (non-descriptor-reg)) ndescr)
 160   (:results (sap :scs (sap-reg)))
 161   (:result-types system-area-pointer)
 162   (:generator 10
 163     (loadw ndescr code 0 other-pointer-lowtag)
 164     (inst srl ndescr n-widetag-bits ndescr)
 165     (inst sll ndescr word-shift ndescr)
 166     (inst addi (- other-pointer-lowtag) ndescr ndescr)
 167     (inst add code ndescr sap)))
 168
 169 (define-vop (compute-fun)
 170   (:args (code :scs (descriptor-reg))
 171          (offset :scs (signed-reg unsigned-reg)))
 172   (:arg-types * positive-fixnum)
 173   (:results (func :scs (descriptor-reg)))
 174   (:temporary (:scs (non-descriptor-reg)) ndescr)
 175   (:generator 10
 176     (loadw ndescr code 0 other-pointer-lowtag)
 177     ;; FIXME-lav: replace below two with DEPW
 178     (inst srl ndescr n-widetag-bits ndescr)
 179     (inst sll ndescr word-shift ndescr)
 180     (inst add ndescr offset ndescr)
 181     (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
 182     (inst add ndescr code func)))
 183
 184 \f
 185 ;;;; Other random VOPs.
 186
 187
 188 (defknown sb!unix::receive-pending-interrupt () (values))
 189 (define-vop (sb!unix::receive-pending-interrupt)
 190   (:policy :fast-safe)
 191   (:translate sb!unix::receive-pending-interrupt)
 192   (:generator 1
 193     (inst break pending-interrupt-trap)))
 194
 195
 196 (define-vop (halt)
 197   (:generator 1
 198     (inst break halt-trap)))
 199
 200 #!+hpux
 201 (define-vop (setup-return-from-lisp-stub)
 202   (:results)
 203   (:save-p t)
 204   (:temporary (:sc any-reg :offset nl0-offset) nl0)
 205   (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
 206   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 207   (:temporary (:scs (non-descriptor-reg)) temp)
 208   (:vop-var vop)
 209   (:generator 100
 210     (let ((stub (make-fixup 'return-from-lisp-stub :assembly-routine)))
 211       (inst li stub nl0))
 212     (let ((cur-nfp (current-nfp-tn vop)))
 213       (when cur-nfp
 214         (store-stack-tn nfp-save cur-nfp))
 215       (inst li (make-fixup "setup_return_from_lisp_stub" :foreign) cfunc)
 216       (let ((fixup (make-fixup "call_into_c" :foreign)))
 217         (inst ldil fixup temp)
 218         (inst ble fixup c-text-space temp))
 219       (inst addi  64 nsp-tn nsp-tn)
 220       (inst addi -64 nsp-tn nsp-tn)
 221       (when cur-nfp
 222         (load-stack-tn cur-nfp nfp-save)))))
 223 \f
 224 ;;;; Dynamic vop count collection support
 225
 226 (define-vop (count-me)
 227   (:args (count-vector :scs (descriptor-reg)))
 228   (:info index)
 229   (:temporary (:scs (non-descriptor-reg)) count)
 230   (:generator 1
 231     (let ((offset
 232            (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
 233       (inst ldw offset count-vector count)
 234       (inst addi 1 count count)
 235       (inst stw count offset count-vector))))
 236
 237 ;;;; Dummy definition for a spin-loop hint VOP
 238 (define-vop (spin-loop-hint)
 239   (:translate spin-loop-hint)
 240   (:policy :fast-safe)
 241   (:generator 0))