>From 28e17805eaf8c8f7b277c1dd2b2f3cf6dc2c3f26 Mon Sep 17 00:00:00 2001
From: LemonBoy
Date: Thu, 22 Jun 2017 18:30:23 +0200
Subject: [PATCH 1/2] Generate type information for the ffi stubs
This way we can finally drop all the handmade ##core#the nodes for the
ffi functions since the scrutinizer is now able to produce more precise
type information.
We also take into account the various conversion procedures for the
foreign types during the scrutinization phase, solving some cases where
we'd blindly use the declared type of the return value without
considering the conversion functions, leading to some bad
misspecializations.
---
chicken-ffi-syntax.scm | 49 +++++------------------------------------
core.scm | 35 +++++++++++++++++++++++------
eval.scm | 2 +-
scrutinizer.scm | 8 ++++++-
support.scm | 4 +++-
tests/specialization-test-1.scm | 7 ++++++
6 files changed, 51 insertions(+), 54 deletions(-)
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index fc9ebbcd..14e376c1 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -220,18 +220,7 @@
(##sys#er-transformer
(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))))
- (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)))))))
+ `(##core#foreign-primitive ,@(cdr form)))))
(##sys#extend-macro-environment
'foreign-lambda
@@ -239,13 +228,7 @@
(##sys#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))))))
+ `(##core#foreign-lambda ,@(cdr form)))))
(##sys#extend-macro-environment
'foreign-lambda*
@@ -253,16 +236,7 @@
(##sys#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))))))
+ `(##core#foreign-lambda* ,@(cdr form)))))
(##sys#extend-macro-environment
'foreign-safe-lambda
@@ -270,13 +244,7 @@
(##sys#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))))))
+ `(##core#foreign-safe-lambda ,@(cdr form)))))
(##sys#extend-macro-environment
'foreign-safe-lambda*
@@ -284,14 +252,7 @@
(##sys#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))))))
+ `(##core#foreign-safe-lambda* ,@(cdr form)))))
(##sys#extend-macro-environment
'foreign-type-size
diff --git a/core.scm b/core.scm
index 4a450335..345b8448 100644
--- a/core.scm
+++ b/core.scm
@@ -181,6 +181,7 @@
; [##core#the { } ]
; [##core#the/result {} ]
; [##core#typecase { ( ...)} ... []]
+; [##core#invoke { } ...]
; - Closure converted/prepared language:
;
@@ -651,6 +652,10 @@
''#t
(walk (cadr x) e se dest ldest h ln tl?) ) )
+ ((##core#invoke)
+ `(##core#invoke
+ ,(cadr x) ,@(mapwalk (cddr x) e se h ln #f)))
+
((##core#the)
`(##core#the
,(strip-syntax (cadr x))
@@ -1797,6 +1802,11 @@
((or (symbol? type) (string? type)) type)
(else 'a))))
(let* ((rtype (strip-syntax rtype))
+ ;; When rtype is #f we assume the function returns via C_values(...),
+ ;; to make this work we do the codegen as if it were returning 'void
+ ;; but give the return value an appropriate type for the scrutiny phase
+ (multiple? (not rtype))
+ (rtype (or rtype 'void))
(argtypes (strip-syntax argtypes))
(params (if argnames
(map gensym argnames)
@@ -1808,11 +1818,15 @@
(set! foreign-lambda-stubs
(cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
foreign-lambda-stubs) )
- (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
- [head (if cps
- `((##core#primitive ,f-id))
- `(##core#inline ,f-id) ) ]
- [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
+ (mark-variable f-id '##compiler#type
+ ;; Add one more argument for the `bufvar' buffer
+ (cons* 'procedure
+ (cons '* (map (cut foreign-type->scrutiny-type <> 'arg) argtypes))
+ (if multiple? '* (list (foreign-type->scrutiny-type rtype 'result)))))
+ (mark-variable f-id '##compiler#type-source 'ffi-stub)
+ (let ((rsize (if callback (+ rsize 24) rsize)) ; 24 -> has to hold cons on 64-bit platforms!
+ (head `(##core#invoke (,f-id ,cps)))
+ (rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)))
`(lambda ,params
;; Do minor GC (if callback) to make room on stack:
,@(if callback '((##sys#gc #f)) '())
@@ -1848,7 +1862,7 @@
;; TODO: Try to fold this procedure into expand-foreign-lambda*
(define (expand-foreign-primitive exp)
(let* ((hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp)))))
- (rtype (if hasrtype (second exp) 'void))
+ (rtype (and hasrtype (second exp)))
(args (strip-syntax (if hasrtype (third exp) (second exp))))
(body (apply string-append (if hasrtype (cdddr exp) (cddr exp))))
(argtypes (map (lambda (x) (car x)) args))
@@ -1943,6 +1957,13 @@
(walk-inline-call class params subs k) )
((##core#call) (walk-call (car subs) (cdr subs) params k))
((##core#callunit) (walk-call-unit (first params) k))
+ ((##core#invoke)
+ (let ((id (first params))
+ (cps? (second params)))
+ (if cps?
+ (walk-call
+ (make-node '##core#primitive (list id) '()) subs (list #t) k)
+ (walk-inline-call '##core#inline (list id) subs k))))
((##core#the ##core#the/result)
;; remove "the" nodes, as they are not used after scrutiny
(walk (car subs) k))
@@ -2124,7 +2145,7 @@
(db-put! db var 'assigned #t)
(walk (car subs) env localenv fullenv here)))
- ((##core#primitive ##core#inline)
+ ((##core#primitive ##core#inline ##core#invoke)
(let ((id (first params)))
(when (and first-analysis here (symbol? id) (get-real-name id))
(set-real-name! id here) )
diff --git a/eval.scm b/eval.scm
index 736de382..c94f574e 100644
--- a/eval.scm
+++ b/eval.scm
@@ -610,7 +610,7 @@
(compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se #f) ]
[(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
- ##core#define-foreign-variable
+ ##core#define-foreign-variable ##core#invoke
##core#define-external-variable ##core#let-location
##core#foreign-primitive ##core#location
##core#foreign-lambda* ##core#define-foreign-type)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 966a4a6f..13dc3650 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -96,7 +96,7 @@
; global symbol properties:
;
; ##compiler#type -> TYPESPEC
-; ##compiler#type-source -> 'db | 'local | 'inference
+; ##compiler#type-source -> 'db | 'local | 'inference | 'ffi-stub
; ##compiler#predicate -> TYPESPEC
; ##compiler#specializations -> (SPECIALIZATION ...)
; ##compiler#local-specializations -> (SPECIALIZATION ...)
@@ -845,6 +845,12 @@
declared to return `~a', which is not compatible"
(first rt) t))))
(list t)))
+ ((##core#invoke)
+ (walk
+ ;; pretend this is a plain call, the safe flag is meaningless
+ (make-node '##core#call (list #t)
+ (cons (make-node '##core#variable (list (first params)) '()) subs))
+ e loc dest tail flow ctags))
((##core#typecase)
(let* ((ts (walk (first subs) e loc #f #f flow ctags))
(trail0 trail)
diff --git a/support.scm b/support.scm
index 6f2ec807..83d6ba6c 100644
--- a/support.scm
+++ b/support.scm
@@ -515,6 +515,8 @@
(list (walk body)) ) ) ) ) )
((lambda ##core#lambda)
(make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
+ ((##core#invoke)
+ (make-node '##core#invoke (cadr x) (map walk (cddr x))))
((##core#the)
(make-node '##core#the
(list (second x) (third x))
@@ -632,7 +634,7 @@
(loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )
((##core#unbox ##core#ref ##core#update ##core#update_i)
(cons* class (walk (car subs)) params (map walk (cdr subs))) )
- ((##core#inline_allocate ##core#let_unboxed)
+ ((##core#inline_allocate ##core#let_unboxed ##core#invoke)
(cons* class params (map walk subs)))
(else (cons class (append params (map walk subs)))) ) ) ) )
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 23327952..fa0ac90a 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -72,4 +72,11 @@ return n;}
(define-specialization (+) 1)
(assert (= (+) 1))
+(define-foreign-type ty int (lambda (x) x) (lambda (x) (/ x 256)))
+
+(define wrong-specialization
+ (foreign-lambda* ty ((int x)) "C_return(x);"))
+;; even though ty is an alias for int we return a rational number here so
+;; number->string shouldn't be specialized for the fixnum case.
+(assert (string=? "1/2" (number->string (wrong-specialization 128))))
)
--
2.11.0