X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fsystem.lisp;h=86cc5001d9d8a3887133589ab22915feb415a56a;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=fb12e336b98549a669b5fea565cabbe58318bfdc;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index fb12e33..86cc500 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!VM") - -(file-comment - "$Header$") ;;;; type frobbing VOPs @@ -217,8 +214,6 @@ :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) @@ -231,8 +226,8 @@ :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)) @@ -240,8 +235,6 @@ (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)) @@ -257,10 +250,17 @@ (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)) @@ -297,212 +297,3 @@ (inst inc (make-ea :dword :base count-vector :disp (- (* (+ vector-data-offset index) word-bytes) other-pointer-type))))) - -;;;; 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)))