>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