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 <megan...@gmail.com>
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 <megan...@gmail.com>
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 <megan...@gmail.com>
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
