X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fc-call.lisp;h=b9307616598ce3239d3347082434a78f6bff724a;hb=74cf7a4d01664fbf72a662ba093ad67ca243b524;hp=0e775a481ec0cb0377a929a0e208ae64eb47dadd;hpb=be9eb6c67b5f43a095c3de17bea945c309d662e4;p=sbcl.git diff --git a/src/compiler/alpha/c-call.lisp b/src/compiler/alpha/c-call.lisp index 0e775a4..b930761 100644 --- a/src/compiler/alpha/c-call.lisp +++ b/src/compiler/alpha/c-call.lisp @@ -13,104 +13,102 @@ (defun my-make-wired-tn (prim-type-name sc-name offset) (make-wired-tn (primitive-type-or-lose prim-type-name ) - (sc-number-or-lose sc-name ) - offset)) + (sc-number-or-lose sc-name ) + offset)) (defstruct arg-state (stack-frame-size 0)) -(def-alien-type-method (integer :arg-tn) (type state) +(define-alien-type-method (integer :arg-tn) (type state) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (multiple-value-bind - (ptype reg-sc stack-sc) - (if (alien-integer-type-signed type) - (values 'signed-byte-64 'signed-reg 'signed-stack) - (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)) + (ptype reg-sc stack-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-64 'signed-reg 'signed-stack) + (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack)) (if (< stack-frame-size 4) - (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset)) - (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4))))))) + (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset)) + (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4))))))) -(def-alien-type-method (system-area-pointer :arg-tn) (type state) +(define-alien-type-method (system-area-pointer :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (if (< stack-frame-size 4) - (my-make-wired-tn 'system-area-pointer - 'sap-reg - (+ stack-frame-size nl0-offset)) - (my-make-wired-tn 'system-area-pointer - 'sap-stack - (* 2 (- stack-frame-size 4)))))) - -(def-alien-type-method (double-float :arg-tn) (type state) + (my-make-wired-tn 'system-area-pointer + 'sap-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + (* 2 (- stack-frame-size 4)))))) + +(define-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (if (< stack-frame-size 6) - (my-make-wired-tn 'double-float - 'double-reg - (+ stack-frame-size nl0-offset)) - (my-make-wired-tn 'double-float - 'double-stack - (* 2 (- stack-frame-size 6)))))) - -(def-alien-type-method (single-float :arg-tn) (type state) + (my-make-wired-tn 'double-float + 'double-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'double-float + 'double-stack + (* 2 (- stack-frame-size 6)))))) + +(define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) (let ((stack-frame-size (arg-state-stack-frame-size state))) (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) (if (< stack-frame-size 6) - (my-make-wired-tn 'single-float - 'single-reg - (+ stack-frame-size nl0-offset)) - (my-make-wired-tn 'single-float - 'single-stack - (* 2 (- stack-frame-size 6)))))) - - - -(def-alien-type-method (integer :result-tn) (type state) + (my-make-wired-tn 'single-float + 'single-reg + (+ stack-frame-size nl0-offset)) + (my-make-wired-tn 'single-float + 'single-stack + (* 2 (- stack-frame-size 6)))))) + +(define-alien-type-method (integer :result-tn) (type state) (declare (ignore state)) (multiple-value-bind (ptype reg-sc) (if (alien-integer-type-signed type) - (values 'signed-byte-64 'signed-reg) - (values 'unsigned-byte-64 'unsigned-reg)) + (values 'signed-byte-64 'signed-reg) + (values 'unsigned-byte-64 'unsigned-reg)) (my-make-wired-tn ptype reg-sc lip-offset))) -(def-alien-type-method (system-area-pointer :result-tn) (type state) +(define-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type state)) (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset)) - -(def-alien-type-method (double-float :result-tn) (type state) + +(define-alien-type-method (double-float :result-tn) (type state) (declare (ignore type state)) (my-make-wired-tn 'double-float 'double-reg lip-offset)) -(def-alien-type-method (single-float :result-tn) (type state) +(define-alien-type-method (single-float :result-tn) (type state) (declare (ignore type state)) (my-make-wired-tn 'single-float 'single-reg lip-offset)) -(def-alien-type-method (values :result-tn) (type state) +(define-alien-type-method (values :result-tn) (type state) (let ((values (alien-values-type-values type))) (when (cdr values) (error "Too many result values from c-call.")) (when values (invoke-alien-type-method :result-tn (car values) state)))) -(!def-vm-support-routine make-call-out-tns (type) +(defun make-call-out-tns (type) (let ((arg-state (make-arg-state))) (collect ((arg-tns)) (dolist (arg-type (alien-fun-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset) - (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes) - (arg-tns) - (invoke-alien-type-method :result-tn - (alien-fun-type-result-type type) - nil))))) - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) + (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-fun-type-result-type type) + nil))))) + +(define-vop (foreign-symbol-sap) + (:translate foreign-symbol-sap) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -122,37 +120,38 @@ (define-vop (call-out) (:args (function :scs (sap-reg) :target cfunc) - (args :more t)) + (args :more t)) (:results (results :more t)) (:ignore args results) (:save-p t) (:temporary (:sc any-reg :offset cfunc-offset - :from (:argument 0) :to (:result 0)) cfunc) + :from (:argument 0) :to (:result 0)) cfunc) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:scs (non-descriptor-reg)) temp) (:vop-var vop) (:generator 0 (let ((cur-nfp (sb!c::current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (move function cfunc) (inst li (make-fixup "call_into_c" :foreign) temp) (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign)) (when cur-nfp - (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))) + (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))) (define-vop (alloc-number-stack-space) (:info amount) (:results (result :scs (sap-reg any-reg))) + (:result-types system-area-pointer) (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst lda nsp-tn (- delta) nsp-tn)) - (t - (inst li delta temp) - (inst subq nsp-tn temp nsp-tn))))) + (cond ((< delta (ash 1 15)) + (inst lda nsp-tn (- delta) nsp-tn)) + (t + (inst li delta temp) + (inst subq nsp-tn temp nsp-tn))))) (move nsp-tn result))) (define-vop (dealloc-number-stack-space) @@ -162,8 +161,8 @@ (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 7) 7))) - (cond ((< delta (ash 1 15)) - (inst lda nsp-tn delta nsp-tn)) - (t - (inst li delta temp) - (inst addq nsp-tn temp nsp-tn))))))) + (cond ((< delta (ash 1 15)) + (inst lda nsp-tn delta nsp-tn)) + (t + (inst li delta temp) + (inst addq nsp-tn temp nsp-tn)))))))