X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fsystem.lisp;h=3b17ce644bf862f0d3fec3a88f31f9fa6ec69abe;hb=6fb6e66f531dfb6140ec3e0cc8f84f6ecd1927ca;hp=fb12e336b98549a669b5fea565cabbe58318bfdc;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index fb12e33..3b17ce6 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 @@ -37,16 +34,16 @@ (:generator 6 (inst mov eax object) (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-type) + (inst cmp al-tn other-pointer-lowtag) (inst jmp :e other-ptr) - (inst cmp al-tn function-pointer-type) + (inst cmp al-tn fun-pointer-lowtag) (inst jmp :e function-ptr) - ;; pick off structures and list pointers + ;; Pick off structures and list pointers. (inst test al-tn 1) (inst jmp :ne done) - ;; pick off fixnums + ;; Pick off fixnums. (inst and al-tn 3) (inst jmp :e done) @@ -55,11 +52,11 @@ (inst jmp done) FUNCTION-PTR - (load-type al-tn object (- sb!vm:function-pointer-type)) + (load-type al-tn object (- sb!vm:fun-pointer-lowtag)) (inst jmp done) OTHER-PTR - (load-type al-tn object (- sb!vm:other-pointer-type)) + (load-type al-tn object (- sb!vm:other-pointer-lowtag)) DONE (inst movzx result al-tn))) @@ -72,7 +69,7 @@ (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (load-type temp function (- sb!vm:function-pointer-type)) + (load-type temp function (- sb!vm:fun-pointer-lowtag)) (inst movzx result temp))) (define-vop (set-function-subtype) @@ -89,7 +86,7 @@ (:generator 6 (move eax type) (inst mov - (make-ea :byte :base function :disp (- function-pointer-type)) + (make-ea :byte :base function :disp (- fun-pointer-lowtag)) al-tn) (move result eax))) @@ -100,7 +97,7 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (loadw res x 0 other-pointer-type) + (loadw res x 0 other-pointer-lowtag) (inst shr res type-bits))) (define-vop (get-closure-length) @@ -110,7 +107,7 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (loadw res x 0 function-pointer-type) + (loadw res x 0 fun-pointer-lowtag) (inst shr res type-bits))) (define-vop (set-header-data) @@ -125,8 +122,8 @@ (:generator 6 (move eax data) (inst shl eax (- type-bits 2)) - (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type))) - (storew eax x 0 other-pointer-type) + (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-lowtag))) + (storew eax x 0 other-pointer-lowtag) (move res x))) (define-vop (make-fixnum) @@ -199,10 +196,10 @@ (:results (sap :scs (sap-reg) :from (:argument 0))) (:result-types system-area-pointer) (:generator 10 - (loadw sap code 0 other-pointer-type) + (loadw sap code 0 other-pointer-lowtag) (inst shr sap type-bits) (inst lea sap (make-ea :byte :base code :index sap :scale 4 - :disp (- other-pointer-type))))) + :disp (- other-pointer-lowtag))))) (define-vop (compute-function) (:args (code :scs (descriptor-reg) :to (:result 0)) @@ -210,41 +207,37 @@ (:arg-types * positive-fixnum) (:results (func :scs (descriptor-reg) :from (:argument 0))) (:generator 10 - (loadw func code 0 other-pointer-type) + (loadw func code 0 other-pointer-lowtag) (inst shr func type-bits) (inst lea func (make-ea :byte :base offset :index func :scale 4 - :disp (- function-pointer-type other-pointer-type))) + :disp (- fun-pointer-lowtag other-pointer-lowtag))) (inst add func code))) -(defknown %function-self (function) function (flushable)) - -(define-vop (%function-self) +(define-vop (%simple-fun-self) (:policy :fast-safe) - (:translate %function-self) + (:translate %simple-fun-self) (:args (function :scs (descriptor-reg))) (:results (result :scs (descriptor-reg))) (:generator 3 - (loadw result function function-self-slot function-pointer-type) + (loadw result function simple-fun-self-slot fun-pointer-lowtag) (inst lea result (make-ea :byte :base result - :disp (- function-pointer-type - (* function-code-offset word-bytes)))))) + :disp (- fun-pointer-lowtag + (* simple-fun-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)) +(def-source-transform %closure-fun (closure) + `(%simple-fun-self ,closure)) -(defknown (setf %function-self) (function function) function (unsafe)) +(def-source-transform %funcallable-instance-fun (fin) + `(%simple-fun-self ,fin)) -(define-vop (%set-function-self) +(define-vop (%set-fun-self) (:policy :fast-safe) - (:translate (setf %function-self)) + (:translate (setf %simple-fun-self)) (:args (new-self :scs (descriptor-reg) :target result :to :result) (function :scs (descriptor-reg) :to :result)) (:temporary (:sc any-reg :from (:argument 0) :to :result) temp) @@ -252,17 +245,24 @@ (:generator 3 (inst lea temp (make-ea :byte :base new-self - :disp (- (ash function-code-offset word-shift) - function-pointer-type))) - (storew temp function function-self-slot function-pointer-type) + :disp (- (ash simple-fun-code-offset word-shift) + fun-pointer-lowtag))) + (storew temp function simple-fun-self-slot fun-pointer-lowtag) (move result new-self))) -;; We would have really liked to use a source-transform for this, but -;; they don't work with SETF functions. -(defknown ((setf %funcallable-instance-function)) (function function) function +;;; 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-fun)) (function function) function (unsafe)) -(deftransform (setf %funcallable-instance-function) ((value fin)) - '(setf (%function-self fin) value)) +;;; 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-fun) ((value fin)) + '(setf (%simple-fun-self fin) value)) ;;;; other miscellaneous VOPs @@ -296,213 +296,4 @@ (:generator 0 (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))) + other-pointer-lowtag)))))