From 78cc27a8c0518a109645d094c68065d027571e1e Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Fri, 29 Nov 2019 21:47:14 +0100 Subject: [PATCH] Don't infer types for foreign lambdas from foreign type with retconv/argconv This is invalid, as shown by #1649. Ideally we'd defer the type inference of foreign types with retconv/argconv to the result of scrutinizer's analysis of the retconv/argconv procedure's result, if known. To do so would be very tricky, as the way the types are determined now is at macro-expansion time, which is before scrutiny. So for now, we assign '* as the type if there's argconv or retconv. --- NEWS | 3 + support.scm | 141 +++++++++++++++++++++----------------- tests/typematch-tests.scm | 24 +++++++ 3 files changed, 105 insertions(+), 63 deletions(-) diff --git a/NEWS b/NEWS index 477ffa40..0890e8fd 100644 --- a/NEWS +++ b/NEWS @@ -39,6 +39,9 @@ (fixes #1440, thanks to "megane"). - In some cases, rest argument lists do not need to be reified, which should make using optional arguments and case-lambda faster (#1623). + - Values from foreign types which have an argument or return value + converter are no longer inferred to have the Scheme type which + corresponds to the raw foreign type, which was incorrect (#1649). - Module system - Trying to export a foreign variable, define-inlined procedure or diff --git a/support.scm b/support.scm index e5eee630..0007acc4 100644 --- a/support.scm +++ b/support.scm @@ -1172,17 +1172,25 @@ ;;; Compute foreign-type conversions: +(define (foreign-type-result-converter t) + (and-let* (((symbol? t)) + (ft (lookup-foreign-type t)) + (retconv (vector-ref ft 2)) ) + retconv)) + +(define (foreign-type-argument-converter t) + (and-let* (((symbol? t)) + (ft (lookup-foreign-type t)) + (argconv (vector-ref ft 1)) ) + argconv)) + (define (foreign-type-convert-result r t) ; Used only in compiler.scm - (or (and-let* (((symbol? t)) - (ft (lookup-foreign-type t)) - (retconv (vector-ref ft 2)) ) + (or (and-let* ((retconv (foreign-type-result-converter t))) (list retconv r) ) r) ) (define (foreign-type-convert-argument a t) ; Used only in compiler.scm - (or (and-let* (((symbol? t)) - (ft (lookup-foreign-type t)) - (argconv (vector-ref ft 1)) ) + (or (and-let* ((argconv (foreign-type-argument-converter t)) ) (list argconv a) ) a) ) @@ -1301,63 +1309,70 @@ ;; Used in chicken-ffi-syntax.scm and scrutinizer.scm (define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result - (let ((ft (final-foreign-type t))) - (case ft - ((void) 'undefined) - ((char unsigned-char) 'char) - ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32) - 'fixnum) - ((float double) - (case mode - ((arg) 'number) - (else 'float))) - ((scheme-pointer nonnull-scheme-pointer) '*) - ((blob) - (case mode - ((arg) '(or boolean blob)) - (else 'blob))) - ((nonnull-blob) 'blob) - ((pointer-vector) - (case mode - ((arg) '(or boolean pointer-vector)) - (else 'pointer-vector))) - ((nonnull-pointer-vector) 'pointer-vector) - ((u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector) - (case mode - ((arg) `(or boolean (struct ,ft))) - (else `(struct ,ft)))) - ((nonnull-u8vector) '(struct u8vector)) - ((nonnull-s8vector) '(struct s8vector)) - ((nonnull-u16vector) '(struct u16vector)) - ((nonnull-s16vector) '(struct s16vector)) - ((nonnull-u32vector) '(struct u32vector)) - ((nonnull-s32vector) '(struct s32vector)) - ((nonnull-u64vector) '(struct u64vector)) - ((nonnull-s64vector) '(struct s64vector)) - ((nonnull-f32vector) '(struct f32vector)) - ((nonnull-f64vector) '(struct f64vector)) - ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64 - unsigned-long) - 'integer) - ((c-pointer) - '(or boolean pointer locative)) - ((nonnull-c-pointer) 'pointer) - ((c-string c-string* unsigned-c-string unsigned-c-string*) - '(or boolean string)) - ((c-string-list c-string-list*) - '(list-of string)) - ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string) - ((symbol) 'symbol) - (else - (cond ((pair? t) - (case (car t) - ((ref pointer function c-pointer) - '(or boolean pointer locative)) - ((const) (foreign-type->scrutiny-type (cadr t) mode)) - ((enum) 'integer) - ((nonnull-pointer nonnull-c-pointer) 'pointer) - (else '*))) - (else '*)))))) + ;; If the foreign type has a converter, it can return a different + ;; type from the native type matching the foreign type (see #1649) + (if (or (and (eq? mode 'arg) (foreign-type-argument-converter t)) + (and (eq? mode 'result) (foreign-type-result-converter t))) + ;; Here we just punt on the type, but it would be better to + ;; find out the result type of the converter procedure. + '* + (let ((ft (final-foreign-type t))) + (case ft + ((void) 'undefined) + ((char unsigned-char) 'char) + ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32) + 'fixnum) + ((float double) + (case mode + ((arg) 'number) + (else 'float))) + ((scheme-pointer nonnull-scheme-pointer) '*) + ((blob) + (case mode + ((arg) '(or boolean blob)) + (else 'blob))) + ((nonnull-blob) 'blob) + ((pointer-vector) + (case mode + ((arg) '(or boolean pointer-vector)) + (else 'pointer-vector))) + ((nonnull-pointer-vector) 'pointer-vector) + ((u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector) + (case mode + ((arg) `(or boolean (struct ,ft))) + (else `(struct ,ft)))) + ((nonnull-u8vector) '(struct u8vector)) + ((nonnull-s8vector) '(struct s8vector)) + ((nonnull-u16vector) '(struct u16vector)) + ((nonnull-s16vector) '(struct s16vector)) + ((nonnull-u32vector) '(struct u32vector)) + ((nonnull-s32vector) '(struct s32vector)) + ((nonnull-u64vector) '(struct u64vector)) + ((nonnull-s64vector) '(struct s64vector)) + ((nonnull-f32vector) '(struct f32vector)) + ((nonnull-f64vector) '(struct f64vector)) + ((integer long size_t ssize_t integer32 unsigned-integer32 integer64 unsigned-integer64 + unsigned-long) + 'integer) + ((c-pointer) + '(or boolean pointer locative)) + ((nonnull-c-pointer) 'pointer) + ((c-string c-string* unsigned-c-string unsigned-c-string*) + '(or boolean string)) + ((c-string-list c-string-list*) + '(list-of string)) + ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string) + ((symbol) 'symbol) + (else + (cond ((pair? t) + (case (car t) + ((ref pointer function c-pointer) + '(or boolean pointer locative)) + ((const) (foreign-type->scrutiny-type (cadr t) mode)) + ((enum) 'integer) + ((nonnull-pointer nonnull-c-pointer) 'pointer) + (else '*))) + (else '*))))))) ;;; Scan expression-node for variable usage: diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm index ac2d447c..59ba506c 100644 --- a/tests/typematch-tests.scm +++ b/tests/typematch-tests.scm @@ -427,4 +427,28 @@ (infer true (= 3 (+ 1 2))) ; Constant folding should happen before / during scrutiny + +;; #1649; foreign types with retconv should not be inferred to have +;; the foreign type's corresponding Scheme type, as the retconv may +;; return a wildly different type. +(define-foreign-type retconverted-foreign-int int identity ->string) +(define-foreign-type argconverted-foreign-int int ->string) + +;; retconverted-type gets annotated with type (procedure () fixnum) +;; 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)) ) + +(let ((argconverted (foreign-lambda argconverted-foreign-int "rand"))) + ;; Currently types with only argconvert get a retconvert as well, + ;; which is set to ##sys#values. Ideally we should recognise this and + ;; know the type is unmodified. + ;(infer fixnum (argconverted)) + (infer-not fixnum (argconverted)) ) + +(let ((unconverted (foreign-lambda int "rand"))) + (infer fixnum (unconverted))) + (test-exit) -- 2.20.1