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 \f
  14 ;;;; type frobbing VOPs
  15
  16 (define-vop (lowtag-of)
  17   (:translate lowtag-of)
  18   (:policy :fast-safe)
  19   (:args (object :scs (any-reg descriptor-reg control-stack)
  20                  :target result))
  21   (:results (result :scs (unsigned-reg)))
  22   (:result-types positive-fixnum)
  23   (:generator 1
  24     (move result object)
  25     (inst and result lowtag-mask)))
  26
  27 (define-vop (widetag-of)
  28   (:translate widetag-of)
  29   (:policy :fast-safe)
  30   (:args (object :scs (descriptor-reg)))
  31   (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
  32   (:results (result :scs (unsigned-reg)))
  33   (:result-types positive-fixnum)
  34   (:generator 6
  35     (inst mov eax object)
  36     (inst and al-tn lowtag-mask)
  37     (inst cmp al-tn other-pointer-lowtag)
  38     (inst jmp :e other-ptr)
  39     (inst cmp al-tn fun-pointer-lowtag)
  40     (inst jmp :e function-ptr)
  41
  42     ;; Pick off structures and list pointers.
  43     (inst test al-tn 1)
  44     (inst jmp :ne done)
  45
  46     ;; Pick off fixnums.
  47     (inst and al-tn 3)
  48     (inst jmp :e done)
  49
  50     ;; must be an other immediate
  51     (inst mov eax object)
  52     (inst jmp done)
  53
  54     FUNCTION-PTR
  55     (load-type al-tn object (- fun-pointer-lowtag))
  56     (inst jmp done)
  57
  58     OTHER-PTR
  59     (load-type al-tn object (- other-pointer-lowtag))
  60
  61     DONE
  62     (inst movzx result al-tn)))
  63 \f
  64 (define-vop (fun-subtype)
  65   (:translate fun-subtype)
  66   (:policy :fast-safe)
  67   (:args (function :scs (descriptor-reg)))
  68   (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
  69   (:results (result :scs (unsigned-reg)))
  70   (:result-types positive-fixnum)
  71   (:generator 6
  72     (load-type temp function (- fun-pointer-lowtag))
  73     (inst movzx result temp)))
  74
  75 (define-vop (set-fun-subtype)
  76   (:translate (setf fun-subtype))
  77   (:policy :fast-safe)
  78   (:args (type :scs (unsigned-reg) :target eax)
  79          (function :scs (descriptor-reg)))
  80   (:arg-types positive-fixnum *)
  81   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
  82                    :to (:result 0) :target result)
  83               eax)
  84   (:results (result :scs (unsigned-reg)))
  85   (:result-types positive-fixnum)
  86   (:generator 6
  87     (move eax type)
  88     (storeb al-tn function 0 fun-pointer-lowtag)
  89     (move result eax)))
  90
  91 (define-vop (get-header-data)
  92   (:translate get-header-data)
  93   (:policy :fast-safe)
  94   (:args (x :scs (descriptor-reg)))
  95   (:results (res :scs (unsigned-reg)))
  96   (:result-types positive-fixnum)
  97   (:generator 6
  98     (loadw res x 0 other-pointer-lowtag)
  99     (inst shr res n-widetag-bits)))
 100
 101 (define-vop (get-closure-length)
 102   (:translate get-closure-length)
 103   (:policy :fast-safe)
 104   (:args (x :scs (descriptor-reg)))
 105   (:results (res :scs (unsigned-reg)))
 106   (:result-types positive-fixnum)
 107   (:generator 6
 108     (loadw res x 0 fun-pointer-lowtag)
 109     (inst shr res n-widetag-bits)))
 110
 111 (define-vop (set-header-data)
 112   (:translate set-header-data)
 113   (:policy :fast-safe)
 114   (:args (x :scs (descriptor-reg) :target res :to (:result 0))
 115          (data :scs (any-reg) :target eax))
 116   (:arg-types * positive-fixnum)
 117   (:results (res :scs (descriptor-reg)))
 118   (:temporary (:sc unsigned-reg :offset eax-offset
 119                    :from (:argument 1) :to (:result 0)) eax)
 120   (:generator 6
 121     (move eax data)
 122     (inst shl eax (- n-widetag-bits 2))
 123     (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag)))
 124     (storew eax x 0 other-pointer-lowtag)
 125     (move res x)))
 126 \f
 127 (define-vop (pointer-hash)
 128   (:translate pointer-hash)
 129   (:args (ptr :scs (any-reg descriptor-reg) :target res))
 130   (:results (res :scs (any-reg descriptor-reg)))
 131   (:policy :fast-safe)
 132   (:generator 1
 133     (move res ptr)
 134     ;; Mask the lowtag, and shift the whole address into a positive
 135     ;; fixnum.
 136     (inst and res (lognot lowtag-mask))
 137     (inst shr res 1)))
 138
 139 (define-vop (make-other-immediate-type)
 140   (:args (val :scs (any-reg descriptor-reg) :target res)
 141          (type :scs (unsigned-reg immediate)))
 142   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
 143   (:generator 2
 144     (move res val)
 145     (inst shl res (- n-widetag-bits 2))
 146     (inst or res (sc-case type
 147                    (unsigned-reg type)
 148                    (immediate (tn-value type))))))
 149 \f
 150 ;;;; allocation
 151
 152 (define-vop (dynamic-space-free-pointer)
 153   (:results (int :scs (sap-reg)))
 154   (:result-types system-area-pointer)
 155   (:translate dynamic-space-free-pointer)
 156   (:policy :fast-safe)
 157   (:generator 1
 158     (load-symbol-value int *allocation-pointer*)))
 159
 160 (define-vop (binding-stack-pointer-sap)
 161   (:results (int :scs (sap-reg)))
 162   (:result-types system-area-pointer)
 163   (:translate binding-stack-pointer-sap)
 164   (:policy :fast-safe)
 165   (:generator 1
 166     (load-binding-stack-pointer int)))
 167
 168 (defknown (setf binding-stack-pointer-sap)
 169     (system-area-pointer) system-area-pointer ())
 170
 171 (define-vop (set-binding-stack-pointer-sap)
 172   (:args (new-value :scs (sap-reg) :target int))
 173   (:arg-types system-area-pointer)
 174   (:results (int :scs (sap-reg)))
 175   (:result-types system-area-pointer)
 176   (:translate (setf binding-stack-pointer-sap))
 177   (:policy :fast-safe)
 178   (:generator 1
 179     (store-binding-stack-pointer new-value)
 180     (move int new-value)))
 181
 182 (define-vop (control-stack-pointer-sap)
 183   (:results (int :scs (sap-reg)))
 184   (:result-types system-area-pointer)
 185   (:translate control-stack-pointer-sap)
 186   (:policy :fast-safe)
 187   (:generator 1
 188     (move int esp-tn)))
 189 \f
 190 ;;;; code object frobbing
 191
 192 (define-vop (code-instructions)
 193   (:translate code-instructions)
 194   (:policy :fast-safe)
 195   (:args (code :scs (descriptor-reg) :to (:result 0)))
 196   (:results (sap :scs (sap-reg) :from (:argument 0)))
 197   (:result-types system-area-pointer)
 198   (:generator 10
 199     (loadw sap code 0 other-pointer-lowtag)
 200     (inst shr sap n-widetag-bits)
 201     (inst lea sap (make-ea :byte :base code :index sap :scale 4
 202                            :disp (- other-pointer-lowtag)))))
 203
 204 (define-vop (compute-fun)
 205   (:args (code :scs (descriptor-reg) :to (:result 0))
 206          (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
 207   (:arg-types * positive-fixnum)
 208   (:results (func :scs (descriptor-reg) :from (:argument 0)))
 209   (:generator 10
 210     (loadw func code 0 other-pointer-lowtag)
 211     (inst shr func n-widetag-bits)
 212     (inst lea func
 213           (make-ea :byte :base offset :index func :scale 4
 214                    :disp (- fun-pointer-lowtag other-pointer-lowtag)))
 215     (inst add func code)))
 216
 217 (define-vop (%simple-fun-self)
 218   (:policy :fast-safe)
 219   (:translate %simple-fun-self)
 220   (:args (function :scs (descriptor-reg)))
 221   (:results (result :scs (descriptor-reg)))
 222   (:generator 3
 223     (loadw result function simple-fun-self-slot fun-pointer-lowtag)
 224     (inst lea result
 225           (make-ea :byte :base result
 226                    :disp (- fun-pointer-lowtag
 227                             (* simple-fun-code-offset n-word-bytes))))))
 228
 229 ;;; The closure function slot is a pointer to raw code on X86 instead
 230 ;;; of a pointer to the code function object itself. This VOP is used
 231 ;;; to reference the function object given the closure object.
 232 (define-source-transform %closure-fun (closure)
 233   `(%simple-fun-self ,closure))
 234
 235 (define-vop (%set-fun-self)
 236   (:policy :fast-safe)
 237   (:translate (setf %simple-fun-self))
 238   (:args (new-self :scs (descriptor-reg) :target result :to :result)
 239          (function :scs (descriptor-reg) :to :result))
 240   (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
 241   (:results (result :scs (descriptor-reg)))
 242   (:generator 3
 243     (inst lea temp (make-ea-for-object-slot new-self simple-fun-code-offset
 244                                             fun-pointer-lowtag))
 245     (storew temp function simple-fun-self-slot fun-pointer-lowtag)
 246     (move result new-self)))
 247 \f
 248 ;;;; other miscellaneous VOPs
 249
 250 (defknown sb!unix::receive-pending-interrupt () (values))
 251 (define-vop (sb!unix::receive-pending-interrupt)
 252   (:policy :fast-safe)
 253   (:translate sb!unix::receive-pending-interrupt)
 254   (:generator 1
 255     (inst break pending-interrupt-trap)))
 256
 257 #!+sb-thread
 258 (defknown current-thread-offset-sap ((unsigned-byte 32))
 259   system-area-pointer (flushable))
 260
 261 #!+sb-thread
 262 (define-vop (current-thread-offset-sap)
 263   (:results (sap :scs (sap-reg)))
 264   (:result-types system-area-pointer)
 265   (:translate current-thread-offset-sap)
 266   (:args (n :scs (unsigned-reg) :target sap))
 267   (:arg-types unsigned-num)
 268   (:policy :fast-safe)
 269   (:generator 2
 270     (inst fs-segment-prefix)
 271     (inst mov sap (make-ea :dword :disp 0 :index n :scale 4))))
 272
 273 (define-vop (halt)
 274   (:generator 1
 275     (inst break halt-trap)))
 276
 277 (defknown float-wait () (values))
 278 (define-vop (float-wait)
 279   (:policy :fast-safe)
 280   (:translate float-wait)
 281   (:vop-var vop)
 282   (:save-p :compute-only)
 283   (:generator 1
 284     (note-next-instruction vop :internal-error)
 285     (inst wait)))
 286 \f
 287 ;;;; Miscellany
 288
 289 ;;; the RDTSC instruction (present on Pentium processors and
 290 ;;; successors) allows you to access the time-stamp counter, a 64-bit
 291 ;;; model-specific register that counts executed cycles. The
 292 ;;; instruction returns the low cycle count in EAX and high cycle
 293 ;;; count in EDX.
 294 ;;;
 295 ;;; In order to obtain more significant results on out-of-order
 296 ;;; processors (such as the Pentium II and later), we issue a
 297 ;;; serializing CPUID instruction before reading the cycle counter.
 298 ;;; This instruction is used for its side effect of emptying the
 299 ;;; processor pipeline, to ensure that the RDTSC instruction is
 300 ;;; executed once all pending instructions have been completed.
 301 ;;; CPUID writes to EBX and ECX in addition to EAX and EDX, so
 302 ;;; they need to be added as temporaries.
 303 ;;;
 304 ;;; Note that cache effects mean that the cycle count can vary for
 305 ;;; different executions of the same code (it counts cycles, not
 306 ;;; retired instructions). Furthermore, the results are per-processor
 307 ;;; and not per-process, so are unreliable on multiprocessor machines
 308 ;;; where processes can migrate between processors.
 309 ;;;
 310 ;;; This method of obtaining a cycle count has the advantage of being
 311 ;;; very fast (around 20 cycles), and of not requiring a system call.
 312 ;;; However, you need to know your processor's clock speed to translate
 313 ;;; this into real execution time.
 314 ;;;
 315 ;;; FIXME: This about the WITH-CYCLE-COUNTER interface a bit, and then
 316 ;;; perhaps export it from SB-SYS.
 317
 318 (defknown %read-cycle-counter () (values (unsigned-byte 32) (unsigned-byte 32)) ())
 319
 320 (define-vop (%read-cycle-counter)
 321   (:policy :fast-safe)
 322   (:translate %read-cycle-counter)
 323   (:temporary (:sc unsigned-reg :offset eax-offset :target lo) eax)
 324   (:temporary (:sc unsigned-reg :offset edx-offset :target hi) edx)
 325   (:temporary (:sc unsigned-reg :offset ebx-offset) ebx)
 326   (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 327   (:ignore ebx ecx)
 328   (:results (hi :scs (unsigned-reg))
 329             (lo :scs (unsigned-reg)))
 330   (:result-types unsigned-num unsigned-num)
 331   (:generator 5
 332      (inst xor eax eax)
 333      (inst cpuid)
 334      (inst rdtsc)
 335      (inst push edx)
 336      (inst push eax)
 337      (inst xor eax eax)
 338      (inst cpuid)
 339      (inst pop lo)
 340      (inst pop hi)))
 341
 342 (defmacro with-cycle-counter (&body body)
 343   "Returns the primary value of BODY as the primary value, and the
 344 number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
 345   (with-unique-names (hi0 hi1 lo0 lo1)
 346     `(multiple-value-bind (,hi0 ,lo0) (%read-cycle-counter)
 347        (values (locally ,@body)
 348                (multiple-value-bind (,hi1 ,lo1) (%read-cycle-counter)
 349                  (+ (ash (- ,hi1 ,hi0) 32)
 350                     (- ,lo1 ,lo0)))))))
 351
 352 #!+sb-dyncount
 353 (define-vop (count-me)
 354   (:args (count-vector :scs (descriptor-reg)))
 355   (:info index)
 356   (:generator 0
 357     (inst inc (make-ea-for-vector-data count-vector :offset index))))