(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)))))
+ (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)
(: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)
(: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))))))
+
projects / sbcl.git / blobdiff