From e95fb6008bef69f65cfd25d5fa641042aef8efac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 22 Jan 2019 06:37:12 -0700 Subject: [PATCH] add `procedure-known-single-valued?` original commit: f2a45ea588003c662bc2109e38ff052832d0c262 --- s/base-lang.ss | 7 ++++--- s/cmacros.ss | 16 ++++++++++++---- s/cp0.ss | 19 ++++++++++++------- s/cpnanopass.ss | 18 +++++++++++------- s/primdata.ss | 2 ++ s/prims.ss | 11 +++++++++++ 6 files changed, 52 insertions(+), 21 deletions(-) diff --git a/s/base-lang.ss b/s/base-lang.ss index e935b3afef..3538ac19d0 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -16,7 +16,8 @@ (module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc lookup-primref primref? primref-name primref-level primref-flags primref-arity primref-signatures sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src - make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags preinfo-lambda-libspec + make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags + preinfo-lambda-flags-set! preinfo-lambda-libspec prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* target-fixnum? target-bignum?) @@ -168,10 +169,10 @@ [(src sexpr) (new src sexpr)])))) (define-record-type preinfo-lambda - (nongenerative #{preinfo-lambda e23pkvo5btgapnzomqgegm-4}) + (nongenerative #{preinfo-lambda e23pkvo5btgapnzomqgegm-5}) (parent preinfo) (sealed #t) - (fields libspec (mutable name) flags) + (fields libspec (mutable name) (mutable flags)) (protocol (lambda (pargs->new) (case-lambda diff --git a/s/cmacros.ss b/s/cmacros.ss index 8a2bddfc53..111bb97f5c 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -753,10 +753,11 @@ (define-constant type-phantom #b01111110) (define-constant type-record #b111) -(define-constant code-flag-system #b0001) -(define-constant code-flag-continuation #b0010) -(define-constant code-flag-mutable-closure #b0100) -(define-constant code-flag-arity-in-closure #b1000) +(define-constant code-flag-system #b00001) +(define-constant code-flag-continuation #b00010) +(define-constant code-flag-mutable-closure #b00100) +(define-constant code-flag-arity-in-closure #b01000) +(define-constant code-flag-single-valued #b10000) (define-constant fixnum-bits (case (constant ptr-bits) @@ -851,6 +852,10 @@ (fxlogor (constant type-code) (fxsll (constant code-flag-arity-in-closure) (constant code-flags-offset)))) +(define-constant type-code-single-valued + (fxlogor (constant type-code) + (fxsll (constant code-flag-single-valued) + (constant code-flags-offset)))) ;; type checks are generally performed by applying the mask to the object ;; then comparing against the type code. a mask equal to @@ -932,6 +937,9 @@ (define-constant mask-code-arity-in-closure (fxlogor (fxsll (constant code-flag-arity-in-closure) (constant code-flags-offset)) (fx- (fxsll 1 (constant code-flags-offset)) 1))) +(define-constant mask-code-single-valued + (fxlogor (fxsll (constant code-flag-single-valued) (constant code-flags-offset)) + (fx- (fxsll 1 (constant code-flags-offset)) 1))) (define-constant mask-thread (constant byte-constant-mask)) (define-constant mask-tlc (constant byte-constant-mask)) (define-constant mask-phantom (constant byte-constant-mask)) diff --git a/s/cp0.ss b/s/cp0.ss index 07c62fde50..8f2fa6a9c6 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -4737,18 +4737,23 @@ [(value tail) (bump sc 1) `(case-lambda ,preinfo - ,(let f ([cl* cl*] [mask 0]) + ,(let f ([cl* cl*] [mask 0] [known-single-valued? #t]) (if (null? cl*) - '() + (begin + (when known-single-valued? + (preinfo-lambda-flags-set! preinfo (fxior (preinfo-lambda-flags preinfo) + (constant code-flag-single-valued)))) + '()) (nanopass-case (Lsrc CaseLambdaClause) (car cl*) [(clause (,x* ...) ,interface ,body) (let ([new-mask (logor mask (if (fx< interface 0) (ash -1 (fx- -1 interface)) (ash 1 interface)))]) (if (= new-mask mask) - (f (cdr cl*) new-mask) - (cons - (with-extended-env ((env x*) (env x* #f)) - `(clause (,x* ...) ,interface ,(cp0 body 'tail env sc wd #f name))) - (f (cdr cl*) new-mask))))]))) + (f (cdr cl*) new-mask known-single-valued?) + (with-extended-env ((env x*) (env x* #f)) + (let ([body (cp0 body 'tail env sc wd #f name)]) + (cons `(clause (,x* ...) ,interface ,body) + (f (cdr cl*) new-mask + (and known-single-valued? (single-valued? body))))))))]))) ...)] [(effect ignored) void-rec] [(test) true-rec] diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 05b7f98035..4e24456dff 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -5014,6 +5014,8 @@ [(e) (%typed-object-check mask-code-mutable-closure type-code-mutable-closure ,e)]) (define-inline 3 $code-arity-in-closure? [(e) (%typed-object-check mask-code-arity-in-closure type-code-arity-in-closure ,e)]) + (define-inline 3 $code-single-valued? + [(e) (%typed-object-check mask-code-single-valued type-code-single-valued ,e)]) (define-inline 2 $unbound-object [() `(quote ,($unbound-object))]) (define-inline 2 void @@ -11977,8 +11979,10 @@ (define Ldoargerr (make-Ldoargerr)) (define-$type-check (L13.5 Pred)) (define make-info - (lambda (name interface*) - (make-info-lambda #f #f #f interface* name))) + (case-lambda + [(name interface*) (make-info name interface* #f)] + [(name interface* single-valued?) + (make-info-lambda #f #f #f interface* name (if single-valued? (constant code-flag-single-valued) 0))])) (define make-arg-opnd (lambda (n) (let ([regnum (length arg-registers)]) @@ -12002,7 +12006,7 @@ (define (make-list*-procedure name) (with-output-language (L13.5 CaseLambdaExpr) (let ([Ltop (make-local-label 'ltop)]) - `(lambda ,(make-info name '(-2)) 0 () + `(lambda ,(make-info name '(-2) #t) 0 () (seq (set! ,%ac0 ,(%inline - ,%ac0 (immediate 1))) ; TODO: would be nice to avoid cmpl here @@ -12554,7 +12558,7 @@ [(cons*-procedure) (make-list*-procedure "cons*")] [($record-procedure) (let ([Ltop (make-local-label 'ltop)]) - `(lambda ,(make-info "$record" '(-2)) 0 () + `(lambda ,(make-info "$record" '(-2) #t) 0 () (if ,(%inline eq? ,%ac0 (immediate 0)) (seq (pariah) (goto ,Ldoargerr)) ,(%seq @@ -12594,7 +12598,7 @@ ,(f (cdr reg*) (fx+ i 1))))))))))] [(vector-procedure) (let ([Ltop (make-local-label 'ltop)]) - `(lambda ,(make-info "vector" '(-1)) 0 () + `(lambda ,(make-info "vector" '(-1) #t) 0 () (if ,(%inline eq? ,%ac0 (immediate 0)) ,(%seq (set! ,%ac0 (literal ,(make-info-literal #f 'object '#() 0))) @@ -12650,7 +12654,7 @@ ,(f (cdr reg*) (fx+ i 1))))))))))] [(list-procedure) (let ([Ltop (make-local-label 'ltop)]) - `(lambda ,(make-info "list" '(-1)) 0 () + `(lambda ,(make-info "list" '(-1) #t) 0 () (if ,(%inline eq? ,%ac0 (immediate 0)) (seq (set! ,%ac0 ,(%constant snil)) @@ -12875,7 +12879,7 @@ (define (argcnt->max-fv n) (max (- n (length arg-registers)) 0)) (let ([Ltop (make-local-label 'Ltop)] [Ltrue (make-local-label 'Ltrue)] [Lfail (make-local-label 'Lfail)]) (define iptr-bytes (in-context Triv (%constant ptr-bytes))) - `(lambda ,(make-info "bytevector=?" '(2)) ,(argcnt->max-fv 2) (,bv1 ,bv2 ,idx ,len2) + `(lambda ,(make-info "bytevector=?" '(2) #t) ,(argcnt->max-fv 2) (,bv1 ,bv2 ,idx ,len2) ,(%seq (set! ,bv1 ,(make-arg-opnd 1)) (set! ,bv2 ,(make-arg-opnd 2)) diff --git a/s/primdata.ss b/s/primdata.ss index df61b46513..687c223b0b 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1533,6 +1533,7 @@ (pretty-print [sig [(ptr) (ptr textual-output-port) -> (void)]] [flags true]) (printf [sig [(string sub-ptr ...) -> (void)]] [flags true]) (procedure-arity-mask [sig [(procedure) -> (sint)]] [flags mifoldable discard safeongoodargs true]) + (procedure-known-single-valued? [sig [(procedure) -> (boolean)]] [flags mifoldable discard safeongoodargs]) (process [sig [(string) -> (list)]] [flags]) (profile-clear-database [sig [() -> (void)]] [flags true]) (profile-clear [sig [() -> (void)]] [flags true]) @@ -1777,6 +1778,7 @@ ($code-pinfo* [flags]) ($code-mutable-closure? [flags]) ($code-arity-in-closure? [flags]) + ($code-single-valued? [flags]) ($collect-rendezvous [flags]) ($compile-backend [flags]) ($compiled-file-header? [flags]) diff --git a/s/prims.ss b/s/prims.ss index 8d5dea3732..5cd197d1aa 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -220,6 +220,12 @@ ($closure-ref x 1) ($code-arity-mask c))))) +(define-who procedure-known-single-valued? + (lambda (x) + (unless (procedure? x) ($oops who "~s is not a procedure" x)) + (let ([c ($closure-code x)]) + ($code-single-valued? c)))) + (let () (define-syntax frob-proc (syntax-rules () @@ -435,6 +441,11 @@ (unless ($code? x) ($oops who "~s is not code" x)) ($code-arity-in-closure? x))) +(define-who $code-single-valued? + (lambda (x) + (unless ($code? x) ($oops who "~s is not code" x)) + ($code-single-valued? x))) + (define $object-address ; not safe and can't be (lambda (x offset) ($object-address x offset)))