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