X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Fc-call.lisp;h=69a5d31e955ab37e82e53b973b10f299e43c874b;hb=9105a2e4a8701814db413aa9ac3c41fd79d5b4f1;hp=0d83e19c2e5860a309ea1547aa6eec32a38e0613;hpb=cb296ae5a022a5b0f1fd573584301b0d2a9493f9;p=sbcl.git diff --git a/src/compiler/hppa/c-call.lisp b/src/compiler/hppa/c-call.lisp index 0d83e19..69a5d31 100644 --- a/src/compiler/hppa/c-call.lisp +++ b/src/compiler/hppa/c-call.lisp @@ -13,14 +13,14 @@ (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 (args 0)) (defstruct (arg-info - (:constructor make-arg-info (offset prim-type reg-sc stack-sc))) + (:constructor make-arg-info (offset prim-type reg-sc stack-sc))) offset prim-type reg-sc @@ -30,8 +30,8 @@ (let ((args (arg-state-args state))) (setf (arg-state-args state) (1+ args)) (if (alien-integer-type-signed type) - (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack) - (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))) + (make-arg-info args 'signed-byte-32 'signed-reg 'signed-stack) + (make-arg-info args 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))) (define-alien-type-method (system-area-pointer :arg-tn) (type state) (declare (ignore type)) @@ -55,7 +55,7 @@ (if (alien-integer-type-signed type) (my-make-wired-tn 'signed-byte-32 'signed-reg nl4-offset) (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl4-offset))) - + (define-alien-type-method (system-area-pointer :result-tn) (type) (declare (ignore type)) (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset)) @@ -71,33 +71,33 @@ (define-alien-type-method (values :result-tn) (type) (let ((values (alien-values-type-values type))) (when values - (assert (null (cdr values))) + (aver (null (cdr values))) (invoke-alien-type-method :result-tn (car values))))) (defun make-arg-tns (type) (let* ((state (make-arg-state)) - (args (mapcar #'(lambda (arg-type) - (invoke-alien-type-method :arg-tn arg-type state)) - (alien-fun-type-arg-types type))) - ;; We need 8 words of cruft, and we need to round up to a multiple - ;; of 16 words. - (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15))) + (args (mapcar #'(lambda (arg-type) + (invoke-alien-type-method :arg-tn arg-type state)) + (alien-fun-type-arg-types type))) + ;; We need 8 words of cruft, and we need to round up to a multiple + ;; of 16 words. + (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15))) (values (mapcar #'(lambda (arg) - (declare (type arg-info arg)) - (let ((offset (arg-info-offset arg)) - (prim-type (arg-info-prim-type arg))) - (cond ((>= offset 4) - (my-make-wired-tn prim-type (arg-info-stack-sc arg) - (- frame-size offset 8 1))) - ((or (eq prim-type 'single-float) - (eq prim-type 'double-float)) - (my-make-wired-tn prim-type (arg-info-reg-sc arg) - (+ offset 4))) - (t - (my-make-wired-tn prim-type (arg-info-reg-sc arg) - (- nl0-offset offset)))))) - args) + (declare (type arg-info arg)) + (let ((offset (arg-info-offset arg)) + (prim-type (arg-info-prim-type arg))) + (cond ((>= offset 4) + (my-make-wired-tn prim-type (arg-info-stack-sc arg) + (- frame-size offset 8 1))) + ((or (eq prim-type 'single-float) + (eq prim-type 'double-float)) + (my-make-wired-tn prim-type (arg-info-reg-sc arg) + (+ offset 4))) + (t + (my-make-wired-tn prim-type (arg-info-reg-sc arg) + (- nl0-offset offset)))))) + args) (* frame-size n-word-bytes)))) (!def-vm-support-routine make-call-out-tns (type) @@ -106,14 +106,14 @@ (arg-tns stack-size) (make-arg-tns type) (values (make-normal-tn *fixnum-primitive-type*) - stack-size - arg-tns - (invoke-alien-type-method - :result-tn - (alien-fun-type-result-type type))))) - -(define-vop (foreign-symbol-address) - (:translate foreign-symbol-address) + stack-size + arg-tns + (invoke-alien-type-method + :result-tn + (alien-fun-type-result-type type))))) + +(define-vop (foreign-symbol-sap) + (:translate foreign-symbol-sap) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -125,26 +125,26 @@ (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 (:scs (any-reg) :to (:result 0)) temp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:vop-var vop) (:generator 0 (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) + (store-stack-tn nfp-save cur-nfp)) (move function cfunc) (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp :nullify t)) + (inst ldil fixup temp) + (inst ble fixup c-text-space temp :nullify t)) (inst nop) (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) + (load-stack-tn cur-nfp nfp-save))))) (define-vop (alloc-number-stack-space) (:info amount) @@ -154,11 +154,11 @@ (move nsp-tn result) (unless (zerop amount) (let ((delta (logandc2 (+ amount 63) 63))) - (cond ((< delta (ash 1 10)) - (inst addi delta nsp-tn nsp-tn)) - (t - (inst li delta temp) - (inst add temp nsp-tn nsp-tn))))))) + (cond ((< delta (ash 1 10)) + (inst addi delta nsp-tn nsp-tn)) + (t + (inst li delta temp) + (inst add temp nsp-tn nsp-tn))))))) (define-vop (dealloc-number-stack-space) (:info amount) @@ -167,8 +167,8 @@ (:generator 0 (unless (zerop amount) (let ((delta (- (logandc2 (+ amount 63) 63)))) - (cond ((<= (- (ash 1 10)) delta) - (inst addi delta nsp-tn nsp-tn)) - (t - (inst li delta temp) - (inst add temp nsp-tn nsp-tn))))))) + (cond ((<= (- (ash 1 10)) delta) + (inst addi delta nsp-tn nsp-tn)) + (t + (inst li delta temp) + (inst add temp nsp-tn nsp-tn)))))))