chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[PATCH 3/3] Let scrutinizer infer types for foreign types with retconv/a


From: megane
Subject: [PATCH 3/3] Let scrutinizer infer types for foreign types with retconv/argconv given
Date: Sun, 01 Dec 2019 14:50:01 +0200
User-agent: mu4e 1.0; emacs 25.1.1

Hi,

Here's some more improvement on the #1649 issue.

This patch just drops the procedure annotation if scrutinizer can infer
it anyway. This gives the scrutinizer a change to make the type a bit
more accurate.

It's still not optimal, though.

The first two commits are just straight-forward refactoring. The last
one is the meat.

Here's a simple example:

  (import scheme
          (chicken base)
          (chicken string)
          (chicken type)
          (chicken foreign))

  (define-foreign-type foo int string->number list)

  (define inch (foreign-lambda foo "rand" foo))

  (compiler-typecase inch ((not *) 1))

;; Before:
;;
;; Error: No typecase match
;;   In file `foreign-lambda-and-retconvert.scm:11',
;;   At the toplevel,
;;   In `compiler-typecase' expression:
;;
;;     (compiler-typecase g21 ((not *) 1) (else (##core#undefined)))
;;
;;   Tested expression does not match any case.
;;
;;   The expression has this type:
;;
;;     (* -> *)
;;
;;   The specified type cases are these:
;;
;;     (not *)

;; After:
;;
;; Error: No typecase match
;;   In file `foreign-lambda-and-retconvert.scm:11',
;;   At the toplevel,
;;   In `compiler-typecase' expression:
;;
;;     (compiler-typecase g21 ((not *) 1) (else (##core#undefined)))
;;
;;   Tested expression does not match any case.
;;
;;   The expression has this type:
;;
;;     (string -> list)
;;
;;   The specified type cases are these:
;;
;;     (not *)

>From 91fcb2a2863856b66bb24dedde4a3b40e7f47f4d Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 1 Dec 2019 09:23:29 +0200
Subject: [PATCH 1/3] * chicken-ffi-syntax.scm: Add annotate-foreign-procedure
 helper function

---
 chicken-ffi-syntax.scm | 53 +++++++++++++++++-------------------------
 1 file changed, 21 insertions(+), 32 deletions(-)

diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 1ba5348b..e11a6a28 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -213,6 +213,15 @@
 
 ;;; Aliases for internal forms
 
+(define (annotate-foreign-procedure e argtypes rtype)
+  `(##core#the
+    (procedure ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type 
<> 'arg)
+                    (chicken.syntax#strip-syntax argtypes))
+              ,(chicken.compiler.support#foreign-type->scrutiny-type
+                (chicken.syntax#strip-syntax rtype) 'result))
+    #f
+    ,e))
+
 (##sys#extend-macro-environment
  'define-foreign-type
  '()
@@ -254,13 +263,9 @@
  (compiler-only-er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'foreign-lambda form '(_ _ _ . _))
-    `(##core#the
-      (procedure ,(map (cut 
chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
-                      (chicken.syntax#strip-syntax (cdddr form)))
-                ,(chicken.compiler.support#foreign-type->scrutiny-type
-                  (chicken.syntax#strip-syntax (cadr form)) 'result))
-      #f
-      (##core#foreign-lambda ,@(cdr form))))))
+    (annotate-foreign-procedure `(##core#foreign-lambda ,@(cdr form))
+                               (cdddr form)
+                               (cadr form)))))
 
 (##sys#extend-macro-environment
  'foreign-lambda*
@@ -268,16 +273,9 @@
  (compiler-only-er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'foreign-lambda* form '(_ _ _ _ . _))
-    `(##core#the
-      (procedure ,(map (lambda (a)
-                        (chicken.compiler.support#foreign-type->scrutiny-type
-                         (car a)
-                         'arg))
-                       (chicken.syntax#strip-syntax (caddr form)))
-                 ,(chicken.compiler.support#foreign-type->scrutiny-type
-                   (chicken.syntax#strip-syntax (cadr form)) 'result))
-      #f
-      (##core#foreign-lambda* ,@(cdr form))))))
+    (annotate-foreign-procedure `(##core#foreign-lambda* ,@(cdr form))
+                               (map car (caddr form))
+                               (cadr form)))))
 
 (##sys#extend-macro-environment
  'foreign-safe-lambda
@@ -285,13 +283,9 @@
  (compiler-only-er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'foreign-safe-lambda form '(_ _ _ . _))
-    `(##core#the
-      (procedure ,(map (cut 
chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
-                       (chicken.syntax#strip-syntax (cdddr form)))
-                 ,(chicken.compiler.support#foreign-type->scrutiny-type
-                   (chicken.syntax#strip-syntax (cadr form)) 'result))
-      #f
-      (##core#foreign-safe-lambda ,@(cdr form))))))
+    (annotate-foreign-procedure `(##core#foreign-safe-lambda ,@(cdr form))
+                               (cdddr form)
+                               (cadr form)))))
 
 (##sys#extend-macro-environment
  'foreign-safe-lambda*
@@ -299,14 +293,9 @@
  (compiler-only-er-transformer
   (lambda (form r c)
     (##sys#check-syntax 'foreign-safe-lambda* form '(_ _ _ _ . _))
-    `(##core#the
-      (procedure ,(map (lambda (a)
-                        (chicken.compiler.support#foreign-type->scrutiny-type 
(car a) 'arg))
-                       (chicken.syntax#strip-syntax (caddr form)))
-                 ,(chicken.compiler.support#foreign-type->scrutiny-type
-                   (chicken.syntax#strip-syntax (cadr form)) 'result))
-      #f
-      (##core#foreign-safe-lambda* ,@(cdr form))))))
+    (annotate-foreign-procedure `(##core#foreign-safe-lambda* ,@(cdr form))
+                               (map car (caddr form))
+                               (cadr form)))))
 
 (##sys#extend-macro-environment
  'foreign-type-size
-- 
2.17.1

>From 3a8f526f1a5f2af633a48f787efb2e4ce073d6e6 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 1 Dec 2019 09:50:18 +0200
Subject: [PATCH 2/3] * chicken-ffi-syntax.scm: Convert foreign-primitive to
 use annotate-foreign-procedure

---
 chicken-ffi-syntax.scm | 22 ++++++++++------------
 1 file changed, 10 insertions(+), 12 deletions(-)

diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index e11a6a28..9e723910 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -217,8 +217,11 @@
   `(##core#the
     (procedure ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type 
<> 'arg)
                     (chicken.syntax#strip-syntax argtypes))
-              ,(chicken.compiler.support#foreign-type->scrutiny-type
-                (chicken.syntax#strip-syntax rtype) 'result))
+              ,@(if rtype
+                    (list (chicken.compiler.support#foreign-type->scrutiny-type
+                           (chicken.syntax#strip-syntax rtype) 'result))
+                    ;; special case for C_values(...). Only triggered by 
foreign-primitive.
+                    '*))
     #f
     ,e))
 
@@ -245,17 +248,12 @@
   (lambda (form r c)
     (##sys#check-syntax 'foreign-primitive form '(_ _ . _))
     (let* ((hasrtype (and (pair? (cddr form)) (not (string? (caddr form)))))
-          (rtype (and hasrtype (chicken.syntax#strip-syntax (cadr form))))
-          (args (chicken.syntax#strip-syntax (if hasrtype (caddr form) (cadr 
form))))
+          (rtype (and hasrtype (cadr form)))
+          (args (if hasrtype (caddr form) (cadr form)))
           (argtypes (map car args)))
-      `(##core#the (procedure
-                   ,(map (cut 
chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
-                         argtypes)
-                   ,@(if (not rtype)
-                         '* ; special case for C_values(...)
-                         (list 
(chicken.compiler.support#foreign-type->scrutiny-type rtype 'result))))
-                  #f
-                  (##core#foreign-primitive ,@(cdr form)))))))
+      (annotate-foreign-procedure `(##core#foreign-primitive ,@(cdr form))
+                                 argtypes
+                                 rtype)))))
 
 (##sys#extend-macro-environment
  'foreign-lambda
-- 
2.17.1

>From bb9e1ff2a43518afa9959eee686d5a2f041c60ea Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 1 Dec 2019 12:59:26 +0200
Subject: [PATCH 3/3] Let scrutinizer infer types for foreign types with
 retconv/argconv given

Not doing any annotation gives the scrutinizer a change to infer the
reconverted arguments. Which it in many cases can do.

For example this:

  (define-foreign-type retconverted-foreign-int int identity ->string)
  (foreign-lambda retconverted-foreign-int "rand")

Gets converted to something like this:

  (set! g14 chicken.string#->string)
  (lambda () (g14 (##core#inline stub23 (##core#undefined))

Which the scrutinizer can handle.

* chicken-ffi-syntax.scm (annotate-foreign-procedure): Don't annotate if 
scrutinizer can infer

  Ideally we could drop the annotation here completely if
      create-foreign-stub just annotated the return type of the stub
      call:

       (##core#inline stub25 (##core#undefined))
       =>
       (the fixnum (##core#inline stub25 (##core#undefined)))

      Generally the scrutinizer can infer the argument types if they
      are converted by enforcing functions like this:

      (lambda (int2730)
        (##core#inline
         stub28
         (##core#undefined)
         (##sys#foreign-fixnum-argument int2730)))
      =>
      (fixnum -> *)

* tests/typematch-tests.scm: Expect more specific type now
---
 chicken-ffi-syntax.scm    | 35 +++++++++++++++++++++++++----------
 tests/typematch-tests.scm |  3 +--
 2 files changed, 26 insertions(+), 12 deletions(-)

diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 9e723910..40d879ac 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -214,16 +214,31 @@
 ;;; Aliases for internal forms
 
 (define (annotate-foreign-procedure e argtypes rtype)
-  `(##core#the
-    (procedure ,(map (cut chicken.compiler.support#foreign-type->scrutiny-type 
<> 'arg)
-                    (chicken.syntax#strip-syntax argtypes))
-              ,@(if rtype
-                    (list (chicken.compiler.support#foreign-type->scrutiny-type
-                           (chicken.syntax#strip-syntax rtype) 'result))
-                    ;; special case for C_values(...). Only triggered by 
foreign-primitive.
-                    '*))
-    #f
-    ,e))
+  (let ((scrut-atypes (map (cut 
chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)
+                          (chicken.syntax#strip-syntax argtypes)))
+       (scrut-rtype (and rtype
+                         (chicken.compiler.support#foreign-type->scrutiny-type
+                          (chicken.syntax#strip-syntax rtype) 'result))))
+    ;; Don't add type annotation if the scrutinizer could
+    ;; infer the same or better.
+    ;;
+    ;; At least these cases should work:
+    ;; (-> <some-known-type>)  => annotate
+    ;; (-> *)                  => no annotation
+    ;; (* ... -> *)            => no annotation
+    ;;
+    (if (and (or (not rtype) (eq? scrut-rtype '*))
+            (every (cut eq? '* <>) scrut-atypes))
+       e
+       `(##core#the
+         (procedure ,scrut-atypes
+                    ,@(if rtype
+                          (list scrut-rtype)
+                          ;; special case for C_values(...). Only
+                          ;; triggered by foreign-primitive.
+                          '*))
+         #f
+         ,e))))
 
 (##sys#extend-macro-environment
  'define-foreign-type
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 59ba506c..42a97ac9 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -438,8 +438,7 @@
 ;; when the return type should be whatever the retconvert argument
 ;; to define-foreign-type returns (string in this case)
 (let ((retconverted (foreign-lambda retconverted-foreign-int "rand")))
-  (infer-not fixnum (retconverted))
-  (infer-not integer (retconverted)) )
+  (infer string (retconverted)))
 
 (let ((argconverted (foreign-lambda argconverted-foreign-int "rand")))
   ;; Currently types with only argconvert get a retconvert as well,
-- 
2.17.1


reply via email to

[Prev in Thread] Current Thread [Next in Thread]