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 3 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 29 29 res)))
 133
 134 (define-vop (make-other-immediate-type)
 135   (:args (val :scs (any-reg descriptor-reg))
 136          (type :scs (any-reg descriptor-reg immediate) :target temp))
 137   (:results (res :scs (any-reg descriptor-reg)))
 138   (:temporary (:scs (non-descriptor-reg)) temp)
 139   (:temporary (:scs (non-descriptor-reg)) t2)
 140   (:generator 2
 141     (sc-case type
 142       ((immediate)
 143         (inst sll val n-widetag-bits temp)
 144         (inst li (tn-value type) t2)
 145         (inst or temp t2 res))
 146       (t
 147         (inst sra type 2 temp)
 148         (inst sll val (- n-widetag-bits 2) res)
 149         (inst or res temp res)))))
 150 \f
 151 ;;;; Allocation
 152
 153 (define-vop (dynamic-space-free-pointer)
 154   (:results (int :scs (sap-reg)))
 155   (:result-types system-area-pointer)
 156   (:translate dynamic-space-free-pointer)
 157   (:policy :fast-safe)
 158   (:generator 1
 159     (move alloc-tn int)))
 160
 161 (define-vop (binding-stack-pointer-sap)
 162   (:results (int :scs (sap-reg)))
 163   (:result-types system-area-pointer)
 164   (:translate binding-stack-pointer-sap)
 165   (:policy :fast-safe)
 166   (:generator 1
 167     (move bsp-tn int)))
 168
 169 (define-vop (control-stack-pointer-sap)
 170   (:results (int :scs (sap-reg)))
 171   (:result-types system-area-pointer)
 172   (:translate control-stack-pointer-sap)
 173   (:policy :fast-safe)
 174   (:generator 1
 175     (move csp-tn int)))
 176
 177 \f
 178 ;;;; Code object frobbing.
 179
 180 (define-vop (code-instructions)
 181   (:translate code-instructions)
 182   (:policy :fast-safe)
 183   (:args (code :scs (descriptor-reg)))
 184   (:temporary (:scs (non-descriptor-reg)) ndescr)
 185   (:results (sap :scs (sap-reg)))
 186   (:result-types system-area-pointer)
 187   (:generator 10
 188     (loadw ndescr code 0 other-pointer-lowtag)
 189     (inst srl ndescr n-widetag-bits ndescr)
 190     (inst sll ndescr word-shift ndescr)
 191     (inst addi (- other-pointer-lowtag) ndescr ndescr)
 192     (inst add code ndescr sap)))
 193
 194 (define-vop (compute-fun)
 195   (:args (code :scs (descriptor-reg))
 196          (offset :scs (signed-reg unsigned-reg)))
 197   (:arg-types * positive-fixnum)
 198   (:results (func :scs (descriptor-reg)))
 199   (:temporary (:scs (non-descriptor-reg)) ndescr)
 200   (:generator 10
 201     (loadw ndescr code 0 other-pointer-lowtag)
 202     ;; FIXME-lav: replace below two with DEPW
 203     (inst srl ndescr n-widetag-bits ndescr)
 204     (inst sll ndescr word-shift ndescr)
 205     (inst add ndescr offset ndescr)
 206     (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
 207     (inst add ndescr code func)))
 208
 209 \f
 210 ;;;; Other random VOPs.
 211
 212
 213 (defknown sb!unix::receive-pending-interrupt () (values))
 214 (define-vop (sb!unix::receive-pending-interrupt)
 215   (:policy :fast-safe)
 216   (:translate sb!unix::receive-pending-interrupt)
 217   (:generator 1
 218     (inst break pending-interrupt-trap)))
 219
 220
 221 (define-vop (halt)
 222   (:generator 1
 223     (inst break halt-trap)))
 224
 225 #!+hpux
 226 (define-vop (setup-return-from-lisp-stub)
 227   (:results)
 228   (:save-p t)
 229   (:temporary (:sc any-reg :offset nl0-offset) nl0)
 230   (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
 231   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
 232   (:temporary (:scs (non-descriptor-reg)) temp)
 233   (:vop-var vop)
 234   (:generator 100
 235     (let ((stub (make-fixup 'return-from-lisp-stub :assembly-routine)))
 236       (inst li stub nl0))
 237     (let ((cur-nfp (current-nfp-tn vop)))
 238       (when cur-nfp
 239         (store-stack-tn nfp-save cur-nfp))
 240       (inst li (make-fixup "setup_return_from_lisp_stub" :foreign) cfunc)
 241       (let ((fixup (make-fixup "call_into_c" :foreign)))
 242         (inst ldil fixup temp)
 243         (inst ble fixup c-text-space temp))
 244       (inst addi  64 nsp-tn nsp-tn)
 245       (inst addi -64 nsp-tn nsp-tn)
 246       (when cur-nfp
 247         (load-stack-tn cur-nfp nfp-save)))))
 248 \f
 249 ;;;; Dynamic vop count collection support
 250
 251 (define-vop (count-me)
 252   (:args (count-vector :scs (descriptor-reg)))
 253   (:info index)
 254   (:temporary (:scs (non-descriptor-reg)) count)
 255   (:generator 1
 256     (let ((offset
 257            (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
 258       (inst ldw offset count-vector count)
 259       (inst addi 1 count count)
 260       (inst stw count offset count-vector))))
 261