;;;; files for more information.
(in-package "SB!VM")
-
-(file-comment
- "$Header$")
\f
;;;; type frobbing VOPs
:disp (- function-pointer-type other-pointer-type)))
(inst add func code)))
-(defknown %function-self (function) function (flushable))
-
(define-vop (%function-self)
(:policy :fast-safe)
(:translate %function-self)
:disp (- function-pointer-type
(* function-code-offset word-bytes))))))
-;;; The closure function slot is a pointer to raw code on X86 instead of
-;;; a pointer to the code function object itself. This VOP is used
+;;; The closure function slot is a pointer to raw code on X86 instead
+;;; of a pointer to the code function object itself. This VOP is used
;;; to reference the function object given the closure object.
(def-source-transform %closure-function (closure)
`(%function-self ,closure))
(def-source-transform %funcallable-instance-function (fin)
`(%function-self ,fin))
-(defknown (setf %function-self) (function function) function (unsafe))
-
(define-vop (%set-function-self)
(:policy :fast-safe)
(:translate (setf %function-self))
(storew temp function function-self-slot function-pointer-type)
(move result new-self)))
-;; We would have really liked to use a source-transform for this, but
-;; they don't work with SETF functions.
+;;; KLUDGE: This seems to be some kind of weird override of the way
+;;; that the objdef.lisp code would ordinarily set up the slot
+;;; accessor. It's inherited from CMU CL, and it works, and naively
+;;; deleting it seemed to cause problems, but it's not obvious why
+;;; it's done this way. Any ideas? -- WHN 2001-08-02
(defknown ((setf %funcallable-instance-function)) (function function) function
(unsafe))
+;;; CMU CL comment:
+;;; We would have really liked to use a source-transform for this, but
+;;; they don't work with SETF functions.
+;;; FIXME: Can't we just use DEFSETF or something?
(deftransform (setf %funcallable-instance-function) ((value fin))
'(setf (%function-self fin) value))
\f
(inst inc (make-ea :dword :base count-vector
:disp (- (* (+ vector-data-offset index) word-bytes)
other-pointer-type)))))
-\f
-;;;; primitive multi-thread support
-
-(defknown control-stack-fork ((simple-array (unsigned-byte 32) (*)) t)
- (member t nil))
-
-(define-vop (control-stack-fork)
- (:policy :fast-safe)
- (:translate control-stack-fork)
- (:args (save-stack :scs (descriptor-reg) :to :result)
- (inherit :scs (descriptor-reg)))
- (:arg-types simple-array-unsigned-byte-32 *)
- (:results (child :scs (descriptor-reg)))
- (:result-types t)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
- (:save-p t)
- (:generator 25
- (inst cmp inherit nil-value)
- (inst jmp :e FRESH-STACK)
-
- ;; Child inherits the stack of the parent.
-
- ;; Setup the return context.
- (inst push (make-fixup nil :code-object return))
- (inst push ebp-tn)
- ;; Save the stack.
- (inst xor index index)
- ;; First the stack-pointer.
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- esp-tn)
- (inst inc index)
- (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
- :foreign))
- (inst jmp-short LOOP)
-
- FRESH-STACK
- ;; Child has a fresh control stack.
-
- ;; Set up the return context.
- (inst push (make-fixup nil :code-object return))
- (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
- :foreign))
- ;; The new FP is the top of the stack.
- (inst push stack)
- ;; Save the stack.
- (inst xor index index)
- ;; First save the adjusted stack-pointer.
- (inst sub stack ebp-tn)
- (inst add stack esp-tn)
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- stack)
- ;; Save the current frame, replacing the OCFP and RA by 0.
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* (+ sb!vm:vector-data-offset 1)
- sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- 0)
- ;; Save 0 for the OCFP.
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* (+ sb!vm:vector-data-offset 2)
- sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- 0)
- (inst add index 3)
- ;; Copy the remainder of the frame, skiping the OCFP and RA which
- ;; are saved above.
- (inst lea stack (make-ea :byte :base ebp-tn :disp -8))
-
- LOOP
- (inst cmp stack esp-tn)
- (inst jmp :le stack-save-done)
- (inst sub stack 4)
- (inst mov temp (make-ea :dword :base stack))
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- temp)
- (inst inc index)
- (inst jmp-short LOOP)
-
- RETURN
- ;; Stack already clean if it reaches here. Parent returns NIL.
- (inst mov child nil-value)
- (inst jmp-short DONE)
-
- STACK-SAVE-DONE
- ;; Cleanup the stack
- (inst add esp-tn 8)
- ;; Child returns T.
- (load-symbol child t)
- DONE))
-
-(defknown control-stack-resume ((simple-array (unsigned-byte 32) (*))
- (simple-array (unsigned-byte 32) (*)))
- (values))
-
-(define-vop (control-stack-resume)
- (:policy :fast-safe)
- (:translate control-stack-resume)
- (:args (save-stack :scs (descriptor-reg) :to :result)
- (new-stack :scs (descriptor-reg) :to :result))
- (:arg-types simple-array-unsigned-byte-32 simple-array-unsigned-byte-32)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
- (:save-p t)
- (:generator 25
- ;; Set up the return context.
- (inst push (make-fixup nil :code-object RETURN))
- (inst push ebp-tn)
- ;; Save the stack.
- (inst xor index index)
- ;; First, the stack-pointer.
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- esp-tn)
- (inst inc index)
- (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
- :foreign))
- LOOP
- (inst cmp stack esp-tn)
- (inst jmp :le STACK-SAVE-DONE)
- (inst sub stack 4)
- (inst mov temp (make-ea :dword :base stack))
- (inst mov (make-ea :dword :base save-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type))
- temp)
- (inst inc index)
- (inst jmp-short LOOP)
-
- STACK-SAVE-DONE
- ;; Clean up the stack
- (inst add esp-tn 8)
-
- ;; Restore the new-stack.
- (inst xor index index)
- ;; First, the stack-pointer.
- (inst mov esp-tn
- (make-ea :dword :base new-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
- (inst inc index)
- (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
- :foreign))
- LOOP2
- (inst cmp stack esp-tn)
- (inst jmp :le STACK-RESTORE-DONE)
- (inst sub stack 4)
- (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset
- sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
- (inst mov (make-ea :dword :base stack) temp)
- (inst inc index)
- (inst jmp-short LOOP2)
- STACK-RESTORE-DONE
- ;; Pop the frame pointer, and resume at the return address.
- (inst pop ebp-tn)
- (inst ret)
-
- ;; Original thread resumes, stack has been cleaned up.
- RETURN))
-
-(defknown control-stack-return ((simple-array (unsigned-byte 32) (*)))
- (values))
-
-(define-vop (control-stack-return)
- (:policy :fast-safe)
- (:translate control-stack-return)
- (:args (new-stack :scs (descriptor-reg) :to :result))
- (:arg-types simple-array-unsigned-byte-32)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
- (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
- (:save-p t)
- (:generator 25
- ;; Restore the new-stack.
- (inst xor index index)
- ;; First the stack-pointer.
- (inst mov esp-tn
- (make-ea :dword :base new-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
- (inst inc index)
- (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
- :foreign))
- LOOP
- (inst cmp stack esp-tn)
- (inst jmp :le STACK-RESTORE-DONE)
- (inst sub stack 4)
- (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
- :disp (- (* sb!vm:vector-data-offset
- sb!vm:word-bytes)
- sb!vm:other-pointer-type)))
- (inst mov (make-ea :dword :base stack) temp)
- (inst inc index)
- (inst jmp-short LOOP)
- STACK-RESTORE-DONE
- ;; Pop the frame pointer, and resume at the return address.
- (inst pop ebp-tn)
- (inst ret)))