- :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)))