suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add procedure-known-single-valued?

Browse Source 
original commit: f2a45ea588003c662bc2109e38ff052832d0c262
This commit is contained in:
Matthew Flatt 2019-01-22 06:37:12 -07:00
parent 8070a7b910
commit e95fb6008b
6 changed files with 52 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
s/base-lang.ss
View File

@ -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

16
s/cmacros.ss
View File

@ -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))

19
s/cp0.ss
View File

@ -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]

18
s/cpnanopass.ss
View File

@ -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))

2
s/primdata.ss
View File

@ -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])

11
s/prims.ss
View File

@ -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)))