From b1d6df48941806dcb37b5c8a128bca41a5e2c266 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Tue, 15 Mar 2005 14:21:42 +0000 Subject: [PATCH] C-INLINE forms can now output multiple values --- src/CHANGELOG | 18 ++++++++- src/cmp/cmpffi.lsp | 94 ++++++++++++++++++++++++++++++------------- src/cmp/cmpfun.lsp | 6 +-- src/cmp/cmpinline.lsp | 2 +- src/cmp/cmpmulti.lsp | 6 +-- 5 files changed, 88 insertions(+), 38 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index c87873ebd..9072e0955 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -20,13 +20,27 @@ ECL 0.9f reference the variable that it was going to initialize, as in (LAMBDA (&OPTIONAL (FOO (1+ FOO))) ...) - - ext:c-uint-max and ext:c-ulong-max did not have the right bignum value. - - All strings in a pathname must be valid C strings, with a null terminating character and no fill pointer. - "+nan" is no longer parsed as a number. +* Foreign function interface (FFI): + + - ext:c-uint-max and ext:c-ulong-max did not have the right bignum value. + + - C-INLINE forms now can output multiple values. For instance + > (compile nil '(lambda (x) + (ffi::c-inline (x) (:int) (values :int :int) + "@;@(return 0)=#0+2; @(return 1)=#0+3;"))) + [...] + # + NIL + NIL + > (funcall * 2) + 4 + 5 + * Visible changes: - Boehm-Weiser garbage collector v 6.4 diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 179cce36c..6c2b0da65 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -95,7 +95,7 @@ (CHARACTER-VALUE 'CHARACTER) (LONG-FLOAT-VALUE 'LONG-FLOAT) (SHORT-FLOAT-VALUE 'SHORT-FLOAT) - (C-INLINE (rep-type->lisp-type (second loc))) + (C-INLINE (rep-type->lisp-type (first (second loc)))) (BIND (var-type (second loc))) (otherwise T))))) @@ -110,7 +110,7 @@ (CHARACTER-VALUE :char) (LONG-FLOAT-VALUE :double) (SHORT-FLOAT-VALUE :float) - (C-INLINE (second loc)) + (C-INLINE (first (second loc))) (BIND (var-rep-type (second loc))) (otherwise :object))))) @@ -234,10 +234,26 @@ (unless (= (length arguments) (length arg-types)) (cmperr "In a C-INLINE form the number of declare arguments and the number of supplied ones do not match:~%~S" `(C-INLINE ,@args))) - (if (lisp-type-p output-type) - (setq output-rep-type (lisp-type->rep-type output-type)) - (setq output-rep-type output-type - output-type (rep-type->lisp-type output-type))) + ;; Find out the output types of the inline form. The syntax is rather relax + ;; output-type = lisp-type | c-type | (values {lisp-type | c-type}*) + (flet ((produce-type-pair (type) + (if (lisp-type-p type) + (cons type (lisp-type->rep-type type)) + (cons (rep-type->lisp-type type) type)))) + (cond ((eq output-type ':void) + (setf output-rep-type '() + output-type 'NIL)) + ((and (consp output-type) (eql (first output-type) 'VALUES)) + (when one-liner + (cmpwarn "A FFI:C-INLINE form cannot be :ONE-LINER and output more than one value: ~A" + args) + (setf one-liner nil)) + (setf output-rep-type (mapcar #'cdr (mapcar #'produce-type-pair (rest output-type))) + output-type 'T)) + (t + (let ((x (produce-type-pair output-type))) + (setf output-type (car x) + output-rep-type (list (cdr x))))))) (let* ((processed-arguments '())) (unless (and (listp arguments) (listp arg-types) @@ -268,26 +284,43 @@ (eq (char c-expression ndx) #\;))) (push (- (char-code (char c-expression ndx)) (char-code #\0)) args-to-be-saved))) - + (setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved)) - (setf output-rep-type (lisp-type->rep-type output-rep-type)) + ;;(setf output-rep-type (lisp-type->rep-type output-rep-type)) + ;; If the form does not output any data, and there are no side ;; effects, try to omit it. - (cond ((eq output-rep-type :void) - (if side-effects - (progn - (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) - (wt ";")) - (cmpwarn "Ignoring form ~S" c-expression)) - NIL) - (one-liner - `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects NIL)) - (t - (let ((output-var (make-lcl-var :rep-type output-rep-type))) - (incf *inline-blocks*) - (wt-nl "{" (rep-type-name output-rep-type) " " output-var ";") - (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-var) - output-var))))) + (when (null output-rep-type) + (if side-effects + (progn + (wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil) + (wt ";")) + (cmpwarn "Ignoring form ~S" c-expression)) + (return-from produce-inline-loc NIL)) + + ;; If the form is a one-liner, we can simply propagate this expression until the + ;; place where the value is used. + (when one-liner + (return-from produce-inline-loc + `(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects NIL))) + + ;; Otherwise we have to set up variables for holding the output. + (flet ((make-output-var (type) + (let ((var (make-lcl-var :rep-type type))) + (wt-nl (rep-type-name type) " " var ";") + var))) + (incf *inline-blocks*) + (wt-nl "{") + (let ((output-vars (mapcar #'make-output-var output-rep-type))) + (wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-vars) + (cond ((= (length output-vars) 1) + (first output-vars)) + (t + (loop for v in output-vars + for i from 0 + do (let ((*destination* `(VALUE ,i))) (set-loc v))) + (wt "NVALUES=" (length output-vars) ";") + 'VALUES)))))) (defun c2c-inline (arguments &rest rest) (let ((*inline-blocks* 0)) @@ -324,14 +357,14 @@ (setf (first l) loc) ))) -(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-var) +(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-vars) (with-input-from-string (s c-expression :start (if (eq (char c-expression 0) #\@) (1+ (or (position #\; c-expression) -1)) 0)) - (when output-var + (when output-vars (wt-nl)) (do ((c (read-char s nil nil) (read-char s nil nil))) @@ -339,10 +372,13 @@ (case c (#\@ (let ((object (read s))) - (cond ((equal object '(RETURN)) - (if output-var - (wt output-var) - (cmperr "Tried to use @RETURN within a one-line C-INLINE form"))) + (cond ((and (consp object) (equal (first object) 'RETURN)) + (let ((ndx (or (second object) 0)) + (l (length output-vars))) + (if (< ndx l) + (wt (nth ndx output-vars)) + (cmperr "Used @(RETURN ~D) in a C-INLINE form with ~D output values" + ndx l)))) (t (when (and (consp object) (eq (first object) 'QUOTE)) (setq object (second object))) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index a30776a8d..2060332f3 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -132,7 +132,7 @@ (defun c2member!2 (fun args &aux (*inline-blocks* 0)) (unwind-exit - (produce-inline-loc (inline-args args) '(T T) :object + (produce-inline-loc (inline-args args) '(T T) '(:object) (case fun (EQ "si_memq(#0,#1)") (EQL "memql(#0,#1)") @@ -158,7 +158,7 @@ (defun c2assoc!2 (fun args &aux (*inline-blocks* 0)) (unwind-exit - (produce-inline-loc (inline-args args) '(T T) :object + (produce-inline-loc (inline-args args) '(T T) '(:object) (case fun (eq "assq(#0,#1)") (eql "assql(#0,#1)") @@ -299,7 +299,7 @@ (eq 'FIXNUM (c1form-primary-type (first c1args))) (eq 'FIXNUM (c1form-primary-type (second c1args))) (make-c1form* 'C-INLINE :type 'fixnum :args - c1args '(fixnum fixnum) 'fixnum + c1args '(fixnum fixnum) '(fixnum) (boole-inline-string op-code) nil t))))) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 3ca58c08e..8b4a7322f 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -179,7 +179,7 @@ (side-effects-p (third ii)) (fun (fifth ii)) (one-liner t)) - (produce-inline-loc inlined-locs arg-types out-rep-type + (produce-inline-loc inlined-locs arg-types (list out-rep-type) fun side-effects-p one-liner)))))) (defun get-inline-info (fname types return-type &aux ii iia) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 35fa7618c..3466616c6 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -183,7 +183,7 @@ (dolist (v vars) (if use-bind (bind (c1form-arg 0 (default-init v)) v) - (set-var '(C-INLINE :object "Cnil" () t nil) v))) + (set-var '(C-INLINE (:object) "Cnil" () t nil) v))) output) (defun do-m-v-setq-any (min-values max-values vars use-bind) @@ -234,8 +234,8 @@ (dolist (v vars) (when labels (wt-label (pop labels))) (if use-bind - (bind '(C-INLINE :object "Cnil" () t nil) v) - (set-var '(C-INLINE :object "Cnil" () t nil) v))) + (bind '(C-INLINE (:object) "Cnil" () t nil) v) + (set-var '(C-INLINE (:object) "Cnil" () t nil) v))) (when labels (wt-label label)))) output))