X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fhppa%2Fc-call.lisp;h=1029ee9feecb42a1ea948c333c5d62d08ddc078b;hb=711f75f20284c41f53485fda882fc7cc9e8e930f;hp=9f3cb9319d912c8745967169c8f91a32d08f2355;hpb=6365d636fa30ff3e2c2ebc9668f978fa0ebc7a0e;p=sbcl.git diff --git a/src/compiler/hppa/c-call.lisp b/src/compiler/hppa/c-call.lisp index 9f3cb93..1029ee9 100644 --- a/src/compiler/hppa/c-call.lisp +++ b/src/compiler/hppa/c-call.lisp @@ -11,109 +11,223 @@ (in-package "SB!VM") -(defun my-make-wired-tn (prim-type-name sc-name offset) +;;; beware that we deal alot here with register-offsets directly +;;; instead of their symbol-name in vm.lisp +;;; offset works differently depending on sc-type +(defun my-make-wired-tn (prim-type-name sc-name offset state) (make-wired-tn (primitive-type-or-lose prim-type-name) - (sc-number-or-lose sc-name) - offset)) + (sc-number-or-lose sc-name) + ;; try to utilize vm.lisp definitions of registers: + (ecase sc-name + ((any-reg sap-reg signed-reg unsigned-reg) + (ecase offset ; FIX: port to other arch ??? + ;(:nfp-offset offset) + (0 nl0-offset) ; On other arch we can + (1 nl1-offset) ; just add an offset to + (2 nl2-offset) ; beginning of args, but on + (3 nl3-offset) ; hppa c-args are spread. + (4 nl4-offset) ; These two are for + (5 nl5-offset))) ; c-return values + ((single-int-carg-reg double-int-carg-reg) + (ecase offset ; FIX: port to other arch ??? + (0 nl0-offset) + (1 nl1-offset) + (2 nl2-offset) + (3 nl3-offset))) + ((single-reg double-reg) ; only for return + (+ 4 offset)) + ;; A tn of stack type tells us that we have data on + ;; stack. This offset is current argument number so + ;; -1 points to the correct place to write that data + ((sap-stack signed-stack unsigned-stack) + (- (arg-state-nargs state) offset 8 1))))) (defstruct arg-state - (args 0)) - -(defstruct (arg-info - (:constructor make-arg-info (offset prim-type reg-sc stack-sc))) - offset - prim-type - reg-sc - stack-sc) + (stack-frame-size 0) + (float-args 0) + nargs) (define-alien-type-method (integer :arg-tn) (type state) - (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)))) + (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-32 'signed-reg 'signed-stack) + (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)) + (if (< stack-frame-size 4) + (my-make-wired-tn ptype reg-sc stack-frame-size state) + (my-make-wired-tn ptype stack-sc stack-frame-size state))))) (define-alien-type-method (system-area-pointer :arg-tn) (type state) (declare (ignore type)) - (let ((args (arg-state-args state))) - (setf (arg-state-args state) (1+ args)) - (make-arg-info args 'system-area-pointer 'sap-reg 'sap-stack))) + (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 state) + (my-make-wired-tn 'system-area-pointer + 'sap-stack + stack-frame-size state)))) -(define-alien-type-method (single-float :arg-tn) (type state) +(define-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) - (let ((args (arg-state-args state))) - (setf (arg-state-args state) (1+ args)) - (make-arg-info args 'single-float 'single-reg 'single-stack))) + (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1)) + (float-args (arg-state-float-args state))) + (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2)) + (setf (arg-state-float-args state) (1+ float-args)) + (cond ((>= stack-frame-size 4) + (my-make-wired-tn 'double-float + 'double-stack + stack-frame-size state)) + (t + (my-make-wired-tn 'double-float + 'double-int-carg-reg + (1+ (* float-args 2)) state))))) -(define-alien-type-method (double-float :arg-tn) (type state) +(define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) - (let ((args (logior (1+ (arg-state-args state)) 1))) - (setf (arg-state-args state) (1+ args)) - (make-arg-info args 'double-float 'double-reg 'double-stack))) - -(define-alien-type-method (integer :result-tn) (type) - (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) + (let ((stack-frame-size (arg-state-stack-frame-size state)) + (float-args (arg-state-float-args state))) + (setf (arg-state-stack-frame-size state) (1+ stack-frame-size)) + (setf (arg-state-float-args state) (1+ float-args)) + (cond ((>= stack-frame-size 4) + (my-make-wired-tn 'single-float + 'single-stack + stack-frame-size state)) + (t + (my-make-wired-tn 'double-float + 'single-int-carg-reg + (* float-args 2) state))))) + +(defstruct result-state + (num-results 0)) + +(define-alien-type-method (integer :result-tn) (type state) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (multiple-value-bind (ptype reg-sc) + (if (alien-integer-type-signed type) + (values 'signed-byte-32 'signed-reg) + (values 'unsigned-byte-32 'unsigned-reg)) + (if (> num-results 1) (error "Too many result values from c-call.")) + (my-make-wired-tn ptype reg-sc (+ num-results 4) state)))) + +(define-alien-type-method (system-area-pointer :result-tn) (type state) (declare (ignore type)) - (my-make-wired-tn 'system-area-pointer 'sap-reg nl4-offset)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (if (> num-results 1) (error "Too many result values from c-call.")) + (my-make-wired-tn 'system-area-pointer 'sap-reg (+ num-results 4) state))) -(define-alien-type-method (single-float :result-tn) (type) +(define-alien-type-method (double-float :result-tn) (type state) (declare (ignore type)) - (my-make-wired-tn 'single-float 'single-reg 4)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'double-float 'double-reg (* num-results 2) state))) -(define-alien-type-method (double-float :result-tn) (type) +(define-alien-type-method (single-float :result-tn) (type state) (declare (ignore type)) - (my-make-wired-tn 'double-float 'double-reg 4)) + (let ((num-results (result-state-num-results state))) + (setf (result-state-num-results state) (1+ num-results)) + (my-make-wired-tn 'single-float 'single-reg (* num-results 2) state))) -(define-alien-type-method (values :result-tn) (type) +(define-alien-type-method (values :result-tn) (type state) (let ((values (alien-values-type-values type))) - (when 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))) - (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) - (* frame-size n-word-bytes)))) - -(!def-vm-support-routine make-call-out-tns (type) - (declare (type alien-fun-type type)) - (multiple-value-bind - (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) + (when (> (length values) 2) + (error "Too many result values from c-call.")) + (mapcar (lambda (type) + (invoke-alien-type-method :result-tn type state)) + values))) + +(defun make-call-out-tns (type) + (let ((arg-state (make-arg-state)) + (nargs 0)) + (dolist (arg-type (alien-fun-type-arg-types type)) + (cond + ((alien-double-float-type-p arg-type) + (incf nargs (logior (1+ nargs) 1))) + (t (incf nargs)))) + (setf (arg-state-nargs arg-state) (logandc2 (+ nargs 8 15) 15)) + (collect ((arg-tns)) + (dolist (arg-type (alien-fun-type-arg-types type)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (values (make-normal-tn *fixnum-primitive-type*) + (* n-word-bytes (logandc2 (+ nargs 8 15) 15)) + (arg-tns) + (invoke-alien-type-method :result-tn + (alien-fun-type-result-type type) + (make-result-state)))))) + +(deftransform %alien-funcall ((function type &rest args)) + (aver (sb!c::constant-lvar-p type)) + (let* ((type (sb!c::lvar-value type)) + (env (sb!kernel:make-null-lexenv)) + (arg-types (alien-fun-type-arg-types type)) + (result-type (alien-fun-type-result-type type))) + (aver (= (length arg-types) (length args))) + ;; We need to do something special for 64-bit integer arguments + ;; and results. + (if (or (some (lambda (type) + (and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (> (sb!alien::alien-integer-type-bits result-type) 32))) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (sb!alien::alien-integer-type-bits type) 32)) + ;; 64-bit long long types are stored in + ;; consecutive locations, endian word order, + ;; aligned to 8 bytes. + (when (oddp (length (new-args))) + (new-args nil)) + (progn (new-args `(ash ,arg -32)) + (new-args `(logand ,arg #xffffffff)) + (if (oddp (length (new-arg-types))) + (new-arg-types (parse-alien-type '(unsigned 32) env))) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32) env)) + (new-arg-types (parse-alien-type '(unsigned 32) env))) + (new-arg-types (parse-alien-type '(unsigned 32) env)))) + (t + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (> (sb!alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((sb!alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (signed 32) (unsigned 32)) + '(values (unsigned 32) (unsigned 32))) + env)))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind + (high low) + (%alien-funcall function + ',(make-alien-fun-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-fun-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))) + (sb!c::give-up-ir1-transform)))) + +(define-vop (foreign-symbol-sap) + (:translate foreign-symbol-sap) (:policy :fast-safe) (:args) (:arg-types (:constant simple-string)) @@ -123,42 +237,62 @@ (:generator 2 (inst li (make-fixup foreign-symbol :foreign) res))) +#!+linkage-table +(define-vop (foreign-symbol-dataref-sap) + (:translate foreign-symbol-dataref-sap) + (:policy :fast-safe) + (:args) + (:arg-types (:constant simple-string)) + (:info foreign-symbol) + (:results (res :scs (sap-reg))) + (:result-types system-area-pointer) + (:temporary (:scs (non-descriptor-reg)) addr) + (:generator 2 + (inst li (make-fixup foreign-symbol :foreign-dataref) addr) + (loadw res addr))) + (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) - (:temporary (:scs (any-reg) :to (:result 0)) temp) + :from (:argument 0) :to (:result 0)) cfunc) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) + ;; Not sure if using nargs is safe ( have we saved it ). + ;; but we cant use any non-descriptor-reg because c-args nl-4 is of that type + (:temporary (:sc non-descriptor-reg :offset nargs-offset) temp) (:vop-var vop) (:generator 0 (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (move function cfunc) + (store-stack-tn nfp-save cur-nfp)) (let ((fixup (make-fixup "call_into_c" :foreign))) - (inst ldil fixup temp) - (inst ble fixup c-text-space temp :nullify t)) - (inst nop) + (inst ldil fixup temp) + (inst ble fixup c-text-space temp) + (move function cfunc t)) (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) + (:result-types system-area-pointer) (:results (result :scs (sap-reg any-reg))) (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (:generator 0 + ;; Because stack grows to higher addresses, we have the result + ;; pointing to an lowerer address than nsp (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))))))) + ;; hp-ux stack grows towards larger addresses and stack must be + ;; allocated in blocks of 64 bytes + (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16 + (cond ((< delta (ash 1 10)) + (inst addi delta nsp-tn nsp-tn)) + (t + (inst li delta temp) + (inst add nsp-tn temp nsp-tn))))))) (define-vop (dealloc-number-stack-space) (:info amount) @@ -166,9 +300,25 @@ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) (: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))))))) + (let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16 + (cond ((< delta (ash 1 10)) + (inst addi (- delta) nsp-tn nsp-tn)) + (t + (inst li (- delta) temp) + (inst sub nsp-tn temp nsp-tn))))))) + +#-sb-xc-host +(defun alien-callback-accessor-form (type sap offset) + (let ((parsed-type type)) + (if (alien-integer-type-p parsed-type) + (let ((bits (sb!alien::alien-integer-type-bits parsed-type))) + (let ((byte-offset + (cond ((< bits n-word-bits) + (- n-word-bytes + (ceiling bits n-byte-bits))) + (t 0)))) + `(deref (sap-alien (sap+ ,sap + ,(+ byte-offset offset)) + (* ,type))))) + `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))) +