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