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