src/compiler/x86/system.lisp

   1 ;;;; x86 VM definitions of various system hacking operations
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 (file-comment
  15  "$Header$")
  16 \f
  17 ;;;; type frobbing VOPs
  18
  19 (define-vop (get-lowtag)
  20   (:translate get-lowtag)
  21   (:policy :fast-safe)
  22   (:args (object :scs (any-reg descriptor-reg control-stack)
  23                  :target result))
  24   (:results (result :scs (unsigned-reg)))
  25   (:result-types positive-fixnum)
  26   (:generator 1
  27     (move result object)
  28     (inst and result lowtag-mask)))
  29
  30 (define-vop (get-type)
  31   (:translate get-type)
  32   (:policy :fast-safe)
  33   (:args (object :scs (descriptor-reg)))
  34   (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
  35   (:results (result :scs (unsigned-reg)))
  36   (:result-types positive-fixnum)
  37   (:generator 6
  38     (inst mov eax object)
  39     (inst and al-tn lowtag-mask)
  40     (inst cmp al-tn other-pointer-type)
  41     (inst jmp :e other-ptr)
  42     (inst cmp al-tn function-pointer-type)
  43     (inst jmp :e function-ptr)
  44
  45     ;; pick off structures and list pointers
  46     (inst test al-tn 1)
  47     (inst jmp :ne done)
  48
  49     ;; pick off fixnums
  50     (inst and al-tn 3)
  51     (inst jmp :e done)
  52
  53     ;; must be an other immediate
  54     (inst mov eax object)
  55     (inst jmp done)
  56
  57     FUNCTION-PTR
  58     (load-type al-tn object (- sb!vm:function-pointer-type))
  59     (inst jmp done)
  60
  61     OTHER-PTR
  62     (load-type al-tn object (- sb!vm:other-pointer-type))
  63
  64     DONE
  65     (inst movzx result al-tn)))
  66 \f
  67 (define-vop (function-subtype)
  68   (:translate function-subtype)
  69   (:policy :fast-safe)
  70   (:args (function :scs (descriptor-reg)))
  71   (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
  72   (:results (result :scs (unsigned-reg)))
  73   (:result-types positive-fixnum)
  74   (:generator 6
  75     (load-type temp function (- sb!vm:function-pointer-type))
  76     (inst movzx result temp)))
  77
  78 (define-vop (set-function-subtype)
  79   (:translate (setf function-subtype))
  80   (:policy :fast-safe)
  81   (:args (type :scs (unsigned-reg) :target eax)
  82          (function :scs (descriptor-reg)))
  83   (:arg-types positive-fixnum *)
  84   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
  85                    :to (:result 0) :target result)
  86               eax)
  87   (:results (result :scs (unsigned-reg)))
  88   (:result-types positive-fixnum)
  89   (:generator 6
  90     (move eax type)
  91     (inst mov
  92           (make-ea :byte :base function :disp (- function-pointer-type))
  93           al-tn)
  94     (move result eax)))
  95
  96 (define-vop (get-header-data)
  97   (:translate get-header-data)
  98   (:policy :fast-safe)
  99   (:args (x :scs (descriptor-reg)))
 100   (:results (res :scs (unsigned-reg)))
 101   (:result-types positive-fixnum)
 102   (:generator 6
 103     (loadw res x 0 other-pointer-type)
 104     (inst shr res type-bits)))
 105
 106 (define-vop (get-closure-length)
 107   (:translate get-closure-length)
 108   (:policy :fast-safe)
 109   (:args (x :scs (descriptor-reg)))
 110   (:results (res :scs (unsigned-reg)))
 111   (:result-types positive-fixnum)
 112   (:generator 6
 113     (loadw res x 0 function-pointer-type)
 114     (inst shr res type-bits)))
 115
 116 (define-vop (set-header-data)
 117   (:translate set-header-data)
 118   (:policy :fast-safe)
 119   (:args (x :scs (descriptor-reg) :target res :to (:result 0))
 120          (data :scs (any-reg) :target eax))
 121   (:arg-types * positive-fixnum)
 122   (:results (res :scs (descriptor-reg)))
 123   (:temporary (:sc unsigned-reg :offset eax-offset
 124                    :from (:argument 1) :to (:result 0)) eax)
 125   (:generator 6
 126     (move eax data)
 127     (inst shl eax (- type-bits 2))
 128     (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
 129     (storew eax x 0 other-pointer-type)
 130     (move res x)))
 131 \f
 132 (define-vop (make-fixnum)
 133   (:args (ptr :scs (any-reg descriptor-reg) :target res))
 134   (:results (res :scs (any-reg descriptor-reg)))
 135   (:generator 1
 136     ;; Some code (the hash table code) depends on this returning a
 137     ;; positive number so make sure it does.
 138     (move res ptr)
 139     (inst shl res 3)
 140     (inst shr res 1)))
 141
 142 (define-vop (make-other-immediate-type)
 143   (:args (val :scs (any-reg descriptor-reg) :target res)
 144          (type :scs (unsigned-reg immediate)))
 145   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
 146   (:generator 2
 147     (move res val)
 148     (inst shl res (- type-bits 2))
 149     (inst or res (sc-case type
 150                    (unsigned-reg type)
 151                    (immediate (tn-value type))))))
 152 \f
 153 ;;;; allocation
 154
 155 (define-vop (dynamic-space-free-pointer)
 156   (:results (int :scs (sap-reg)))
 157   (:result-types system-area-pointer)
 158   (:translate dynamic-space-free-pointer)
 159   (:policy :fast-safe)
 160   (:generator 1
 161     (load-symbol-value int *allocation-pointer*)))
 162
 163 (define-vop (binding-stack-pointer-sap)
 164   (:results (int :scs (sap-reg)))
 165   (:result-types system-area-pointer)
 166   (:translate binding-stack-pointer-sap)
 167   (:policy :fast-safe)
 168   (:generator 1
 169     (load-symbol-value int *binding-stack-pointer*)))
 170
 171 (defknown (setf binding-stack-pointer-sap)
 172     (system-area-pointer) system-area-pointer ())
 173
 174 (define-vop (set-binding-stack-pointer-sap)
 175   (:args (new-value :scs (sap-reg) :target int))
 176   (:arg-types system-area-pointer)
 177   (:results (int :scs (sap-reg)))
 178   (:result-types system-area-pointer)
 179   (:translate (setf binding-stack-pointer-sap))
 180   (:policy :fast-safe)
 181   (:generator 1
 182     (store-symbol-value new-value *binding-stack-pointer*)
 183     (move int new-value)))
 184
 185 (define-vop (control-stack-pointer-sap)
 186   (:results (int :scs (sap-reg)))
 187   (:result-types system-area-pointer)
 188   (:translate control-stack-pointer-sap)
 189   (:policy :fast-safe)
 190   (:generator 1
 191     (move int esp-tn)))
 192 \f
 193 ;;;; code object frobbing
 194
 195 (define-vop (code-instructions)
 196   (:translate code-instructions)
 197   (:policy :fast-safe)
 198   (:args (code :scs (descriptor-reg) :to (:result 0)))
 199   (:results (sap :scs (sap-reg) :from (:argument 0)))
 200   (:result-types system-area-pointer)
 201   (:generator 10
 202     (loadw sap code 0 other-pointer-type)
 203     (inst shr sap type-bits)
 204     (inst lea sap (make-ea :byte :base code :index sap :scale 4
 205                            :disp (- other-pointer-type)))))
 206
 207 (define-vop (compute-function)
 208   (:args (code :scs (descriptor-reg) :to (:result 0))
 209          (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
 210   (:arg-types * positive-fixnum)
 211   (:results (func :scs (descriptor-reg) :from (:argument 0)))
 212   (:generator 10
 213     (loadw func code 0 other-pointer-type)
 214     (inst shr func type-bits)
 215     (inst lea func
 216           (make-ea :byte :base offset :index func :scale 4
 217                    :disp (- function-pointer-type other-pointer-type)))
 218     (inst add func code)))
 219
 220 (defknown %function-self (function) function (flushable))
 221
 222 (define-vop (%function-self)
 223   (:policy :fast-safe)
 224   (:translate %function-self)
 225   (:args (function :scs (descriptor-reg)))
 226   (:results (result :scs (descriptor-reg)))
 227   (:generator 3
 228     (loadw result function function-self-slot function-pointer-type)
 229     (inst lea result
 230           (make-ea :byte :base result
 231                    :disp (- function-pointer-type
 232                             (* function-code-offset word-bytes))))))
 233
 234 ;;; The closure function slot is a pointer to raw code on X86 instead of
 235 ;;; a pointer to the code function object itself. This VOP is used
 236 ;;; to reference the function object given the closure object.
 237 (def-source-transform %closure-function (closure)
 238   `(%function-self ,closure))
 239
 240 (def-source-transform %funcallable-instance-function (fin)
 241   `(%function-self ,fin))
 242
 243 (defknown (setf %function-self) (function function) function  (unsafe))
 244
 245 (define-vop (%set-function-self)
 246   (:policy :fast-safe)
 247   (:translate (setf %function-self))
 248   (:args (new-self :scs (descriptor-reg) :target result :to :result)
 249          (function :scs (descriptor-reg) :to :result))
 250   (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
 251   (:results (result :scs (descriptor-reg)))
 252   (:generator 3
 253     (inst lea temp
 254           (make-ea :byte :base new-self
 255                    :disp (- (ash function-code-offset word-shift)
 256                             function-pointer-type)))
 257     (storew temp function function-self-slot function-pointer-type)
 258     (move result new-self)))
 259
 260 ;; We would have really liked to use a source-transform for this, but
 261 ;; they don't work with SETF functions.
 262 (defknown ((setf %funcallable-instance-function)) (function function) function
 263   (unsafe))
 264 (deftransform (setf %funcallable-instance-function) ((value fin))
 265   '(setf (%function-self fin) value))
 266 \f
 267 ;;;; other miscellaneous VOPs
 268
 269 (defknown sb!unix::do-pending-interrupt () (values))
 270 (define-vop (sb!unix::do-pending-interrupt)
 271   (:policy :fast-safe)
 272   (:translate sb!unix::do-pending-interrupt)
 273   (:generator 1
 274     (inst break pending-interrupt-trap)))
 275
 276 (define-vop (halt)
 277   (:generator 1
 278     (inst break halt-trap)))
 279
 280 (defknown float-wait () (values))
 281 (define-vop (float-wait)
 282   (:policy :fast-safe)
 283   (:translate float-wait)
 284   (:vop-var vop)
 285   (:save-p :compute-only)
 286   (:generator 1
 287     (note-next-instruction vop :internal-error)
 288     (inst wait)))
 289 \f
 290 ;;;; dynamic vop count collection support
 291
 292 #!+sb-dyncount
 293 (define-vop (count-me)
 294   (:args (count-vector :scs (descriptor-reg)))
 295   (:info index)
 296   (:generator 0
 297     (inst inc (make-ea :dword :base count-vector
 298                        :disp (- (* (+ vector-data-offset index) word-bytes)
 299                                 other-pointer-type)))))