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)))))
 300 \f
 301 ;;;; primitive multi-thread support
 302
 303 (defknown control-stack-fork ((simple-array (unsigned-byte 32) (*)) t)
 304   (member t nil))
 305
 306 (define-vop (control-stack-fork)
 307   (:policy :fast-safe)
 308   (:translate control-stack-fork)
 309   (:args (save-stack :scs (descriptor-reg) :to :result)
 310          (inherit :scs (descriptor-reg)))
 311   (:arg-types simple-array-unsigned-byte-32 *)
 312   (:results (child :scs (descriptor-reg)))
 313   (:result-types t)
 314   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
 315   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
 316   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
 317   (:save-p t)
 318   (:generator 25
 319     (inst cmp inherit *nil-value*)
 320     (inst jmp :e FRESH-STACK)
 321
 322     ;; Child inherits the stack of the parent.
 323
 324     ;; Setup the return context.
 325     (inst push (make-fixup nil :code-object return))
 326     (inst push ebp-tn)
 327     ;; Save the stack.
 328     (inst xor index index)
 329     ;; First the stack-pointer.
 330     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 331                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 332                                 sb!vm:other-pointer-type))
 333           esp-tn)
 334     (inst inc index)
 335     (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
 336                                 :foreign))
 337     (inst jmp-short LOOP)
 338
 339     FRESH-STACK
 340     ;; Child has a fresh control stack.
 341
 342     ;; Set up the return context.
 343     (inst push (make-fixup nil :code-object return))
 344     (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
 345                                 :foreign))
 346     ;; The new FP is the top of the stack.
 347     (inst push stack)
 348     ;; Save the stack.
 349     (inst xor index index)
 350     ;; First save the adjusted stack-pointer.
 351     (inst sub stack ebp-tn)
 352     (inst add stack esp-tn)
 353     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 354                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 355                                 sb!vm:other-pointer-type))
 356           stack)
 357     ;; Save the current frame, replacing the OCFP and RA by 0.
 358     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 359                        :disp (- (* (+ sb!vm:vector-data-offset 1)
 360                                    sb!vm:word-bytes)
 361                                 sb!vm:other-pointer-type))
 362           0)
 363     ;; Save 0 for the OCFP.
 364     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 365                        :disp (- (* (+ sb!vm:vector-data-offset 2)
 366                                    sb!vm:word-bytes)
 367                                 sb!vm:other-pointer-type))
 368           0)
 369     (inst add index 3)
 370     ;; Copy the remainder of the frame, skiping the OCFP and RA which
 371     ;; are saved above.
 372     (inst lea stack (make-ea :byte :base ebp-tn :disp -8))
 373
 374     LOOP
 375     (inst cmp stack esp-tn)
 376     (inst jmp :le stack-save-done)
 377     (inst sub stack 4)
 378     (inst mov temp (make-ea :dword :base stack))
 379     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 380                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 381                                 sb!vm:other-pointer-type))
 382           temp)
 383     (inst inc index)
 384     (inst jmp-short LOOP)
 385
 386     RETURN
 387     ;; Stack already clean if it reaches here. Parent returns NIL.
 388     (inst mov child *nil-value*)
 389     (inst jmp-short DONE)
 390
 391     STACK-SAVE-DONE
 392     ;; Cleanup the stack
 393     (inst add esp-tn 8)
 394     ;; Child returns T.
 395     (load-symbol child t)
 396     DONE))
 397
 398 (defknown control-stack-resume ((simple-array (unsigned-byte 32) (*))
 399                                 (simple-array (unsigned-byte 32) (*)))
 400   (values))
 401
 402 (define-vop (control-stack-resume)
 403   (:policy :fast-safe)
 404   (:translate control-stack-resume)
 405   (:args (save-stack :scs (descriptor-reg) :to :result)
 406          (new-stack :scs (descriptor-reg) :to :result))
 407   (:arg-types simple-array-unsigned-byte-32 simple-array-unsigned-byte-32)
 408   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
 409   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
 410   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
 411   (:save-p t)
 412   (:generator 25
 413     ;; Set up the return context.
 414     (inst push (make-fixup nil :code-object RETURN))
 415     (inst push ebp-tn)
 416     ;; Save the stack.
 417     (inst xor index index)
 418     ;; First, the stack-pointer.
 419     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 420                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 421                                 sb!vm:other-pointer-type))
 422           esp-tn)
 423     (inst inc index)
 424     (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
 425                                 :foreign))
 426     LOOP
 427     (inst cmp stack esp-tn)
 428     (inst jmp :le STACK-SAVE-DONE)
 429     (inst sub stack 4)
 430     (inst mov temp (make-ea :dword :base stack))
 431     (inst mov (make-ea :dword :base save-stack :index index :scale 4
 432                        :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 433                                 sb!vm:other-pointer-type))
 434           temp)
 435     (inst inc index)
 436     (inst jmp-short LOOP)
 437
 438     STACK-SAVE-DONE
 439     ;; Clean up the stack
 440     (inst add esp-tn 8)
 441
 442     ;; Restore the new-stack.
 443     (inst xor index index)
 444     ;; First, the stack-pointer.
 445     (inst mov esp-tn
 446           (make-ea :dword :base new-stack :index index :scale 4
 447                    :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 448                             sb!vm:other-pointer-type)))
 449     (inst inc index)
 450     (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
 451                                 :foreign))
 452     LOOP2
 453     (inst cmp stack esp-tn)
 454     (inst jmp :le STACK-RESTORE-DONE)
 455     (inst sub stack 4)
 456     (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
 457                             :disp (- (* sb!vm:vector-data-offset
 458                                         sb!vm:word-bytes)
 459                                      sb!vm:other-pointer-type)))
 460     (inst mov (make-ea :dword :base stack) temp)
 461     (inst inc index)
 462     (inst jmp-short LOOP2)
 463     STACK-RESTORE-DONE
 464     ;; Pop the frame pointer, and resume at the return address.
 465     (inst pop ebp-tn)
 466     (inst ret)
 467
 468     ;; Original thread resumes, stack has been cleaned up.
 469     RETURN))
 470
 471 (defknown control-stack-return ((simple-array (unsigned-byte 32) (*)))
 472   (values))
 473
 474 (define-vop (control-stack-return)
 475   (:policy :fast-safe)
 476   (:translate control-stack-return)
 477   (:args (new-stack :scs (descriptor-reg) :to :result))
 478   (:arg-types simple-array-unsigned-byte-32)
 479   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
 480   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
 481   (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
 482   (:save-p t)
 483   (:generator 25
 484     ;; Restore the new-stack.
 485     (inst xor index index)
 486     ;; First the stack-pointer.
 487     (inst mov esp-tn
 488           (make-ea :dword :base new-stack :index index :scale 4
 489                    :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
 490                             sb!vm:other-pointer-type)))
 491     (inst inc index)
 492     (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
 493                                 :foreign))
 494     LOOP
 495     (inst cmp stack esp-tn)
 496     (inst jmp :le STACK-RESTORE-DONE)
 497     (inst sub stack 4)
 498     (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
 499                             :disp (- (* sb!vm:vector-data-offset
 500                                         sb!vm:word-bytes)
 501                                      sb!vm:other-pointer-type)))
 502     (inst mov (make-ea :dword :base stack) temp)
 503     (inst inc index)
 504     (inst jmp-short LOOP)
 505     STACK-RESTORE-DONE
 506     ;; Pop the frame pointer, and resume at the return address.
 507     (inst pop ebp-tn)
 508     (inst ret)))