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

cs: improve procedure-result-arity

Browse Source
This commit is contained in:
Matthew Flatt 2019-01-22 17:31:36 -07:00
parent 3b99688275
commit 8e5e5b9467
9 changed files with 53 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
pkgs/racket-test-core/tests/racket/function.rktl
View File

@ -111,9 +111,13 @@
(test 1 procedure-result-arity car)
(test 1 procedure-result-arity list)
(test 1 procedure-result-arity (procedure-reduce-arity car 1))
(test (arity-at-least 0) procedure-result-arity values)
(test (arity-at-least 0) procedure-result-arity (procedure-reduce-arity values 1))
(test (arity-at-least 0) procedure-result-arity call/cc)
(let ([adjust-no-information (lambda (x)
;; `(arity-at-least 0)` is the same as `#f`,
;; since both are no information
(or x (arity-at-least 0)))])
(test (arity-at-least 0) adjust-no-information (procedure-result-arity values))
(test (arity-at-least 0) adjust-no-information (procedure-result-arity (procedure-reduce-arity values 1)))
(test (arity-at-least 0) adjust-no-information (procedure-result-arity call/cc)))
(let ()
(struct s (x))
(test 1 procedure-result-arity s-x)
@ -152,11 +156,14 @@
[(a b c d e f) (values 1 2 3 4 5 6 7 8)]
[(a b . whatever) a]))))
;; hopefully this test will start failing at
;; some point and return 1 instead of #f
(let ()
(struct s (f) #:property prop:procedure 0)
(test #f procedure-result-arity (s car)))
(test (case (system-type 'vm)
;; maybe this test will start failing at
;; some point and return 1 instead of #f
[(racket) #f]
[else 1])
procedure-result-arity (s car)))
;; ---------- identity ----------
(let ()

1
racket/src/cs/Makefile
View File

@ -246,6 +246,7 @@ RUMBLE_SRCS = rumble/define.ss \
rumble/thread-cell.ss \
rumble/parameter.ss \
rumble/begin0.ss \
rumble/value.ss \
rumble/pthread.ss \
rumble/control.ss \
rumble/interrupt.ss \

2
racket/src/cs/rumble.sls
View File

@ -5,6 +5,7 @@
null eof void void?
begin0
$value
letrec*/names
@ -706,6 +707,7 @@
(include "rumble/begin0.ss")
(include "rumble/letrec.ss")
(include "rumble/syntax-rule.ss")
(include "rumble/value.ss")
(include "rumble/lock.ss")
(include "rumble/thread-local.ss")
(include "rumble/version.ss")

23
racket/src/cs/rumble/procedure.ss
View File

@ -278,9 +278,26 @@
(define/who (procedure-result-arity p)
(check who procedure? p)
(and (#%procedure? p)
(procedure-known-single-valued? p)
1))
(cond
[(#%procedure? p)
(and (procedure-known-single-valued? p)
1)]
[(impersonator? p)
(procedure-result-arity (strip-impersonator p))]
[(record? p)
(let* ([rtd (record-rtd p)]
[v (struct-property-ref prop:procedure rtd none)])
(cond
[(eq? v none) #f]
[(fixnum? v)
(procedure-result-arity (unsafe-struct-ref p v))]
[(eq? v 'unsafe)
(procedure-result-arity
(if (chaperone? p)
(unsafe-procedure-chaperone-replace-proc p)
(unsafe-procedure-impersonator-replace-proc p)))]
[else (procedure-result-arity v)]))]
[else #f]))
;; ----------------------------------------

7
racket/src/cs/rumble/struct.ss
View File

@ -652,9 +652,10 @@
[wrap-p
(procedure-rename
(lambda (v)
(if (impersonator? v)
(impersonate-ref p rtd pos v)
(p v)))
($value
(if (impersonator? v)
(impersonate-ref p rtd pos v)
(p v))))
(string->symbol (string-append (symbol->string (record-type-name rtd))
"-"
(if name

7
racket/src/cs/rumble/value.ss Normal file
View File

@ -0,0 +1,7 @@
;; Declare/enforce that an expression has a single result, which can
;; enable the optimizer to infer that an enclosing procedure always
;; has a single result. Beware that the subexpression of `$value`
;; is not in tail position.
(define-syntax-rule ($value x)
(#%$value x))

2
racket/src/schemify/interpret.rkt
View File

@ -227,7 +227,7 @@
(vector 'begin0
(compile-expr e env stack-depth stk-i #f)
new-body)]
[`(pariah ,e)
[`($value ,e)
(compile-expr e env stack-depth stk-i tail?)]
[`(if ,tst ,thn ,els)
(define then-stk-i (stack-info-branch stk-i))

4
racket/src/schemify/jitify.rkt
View File

@ -265,10 +265,10 @@
(values (reannotate v `(begin0 ,new-v0 . ,new-body))
new-free
new-lifts)]
[`(pariah ,e)
[`($value ,e)
(define-values (new-e new-free new-lifts)
(jitify-expr e env mutables free lifts convert-mode name in-name))
(values (reannotate v `(pariah ,new-e))
(values (reannotate v `($value ,new-e))
new-free
new-lifts)]
[`(if ,tst ,thn ,els)

6
racket/src/schemify/schemify.rkt
View File

@ -445,7 +445,7 @@
`(struct-type-constructor-add-guards ,ctr ,struct:s ',(struct-type-info-name sti)))))
(define ,raw-s? (record-predicate ,struct:s))
,@(if can-impersonate?
`((define ,s? (lambda (v) (if (,raw-s? v) #t (pariah (if (impersonator? v) (,raw-s? (impersonator-val v)) #f))))))
`((define ,s? (lambda (v) (if (,raw-s? v) #t ($value (if (impersonator? v) (,raw-s? (impersonator-val v)) #f))))))
null)
,@(for/list ([acc/mut (in-list acc/muts)]
[make-acc/mut (in-list make-acc/muts)])
@ -459,7 +459,7 @@
(define ,acc/mut
(lambda (s) (if (,raw-s? s)
(,raw-acc/mut s)
(pariah (impersonate-ref ,raw-acc/mut ,struct:s ,pos s))))))
($value (impersonate-ref ,raw-acc/mut ,struct:s ,pos s))))))
raw-def)]
[`(make-struct-field-mutator ,(? (lambda (v) (wrap-eq? v -set!))) ,pos ,_)
(define raw-def `(define ,raw-acc/mut (record-mutator ,struct:s ,pos)))
@ -471,7 +471,7 @@
(define ,acc/mut
(lambda (s v) (if (,raw-s? s)
(,raw-acc/mut s v)
(pariah (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v))))))
($value (impersonate-set! ,raw-acc/mut ,struct:s ,pos ,abs-pos s v))))))
raw-def)]
[`,_ (error "oops")]))
(define ,(gensym)