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