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

cs: move letrec conversion to schemify

Browse Source 
Instead of having schemify generate `letrec*` and convert as needed
through a Chez Scheme macro, have schemify perform any necessary
conversion to get the right use-before-definition error messages and
`call/cc` interaction.

This change improves the conversion, since schemify has more
information about bindings, but it also avoids sending Racket terms
through a macro-generating macro at the Chez Scheme level. Avoiding
the macro-generating macro avoids a kind of leak in Chez Scheme, where
a gensym used in a template may become ineligible for GC due to the
way `free-id=?` may both reify the gensym's unique name and attach a
property to the gensym.
This commit is contained in:
Matthew Flatt 2019-05-26 21:00:37 -06:00
parent fe708871bd
commit 9d3a49f265
16 changed files with 293 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
racket/src/cs/Makefile
View File

@ -245,7 +245,6 @@ RUMBLE_SRCS = rumble/define.ss \
rumble/layout.ss \ rumble/layout.ss \
rumble/check.ss \ rumble/check.ss \
rumble/syntax-rule.ss \ rumble/syntax-rule.ss \
rumble/letrec.ss \
rumble/constant.ss \ rumble/constant.ss \
rumble/hash-code.ss \ rumble/hash-code.ss \
rumble/struct.ss \ rumble/struct.ss \

2
racket/src/cs/convert.rkt
View File

@ -127,7 +127,7 @@
(time (time
(schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode? #t))) (schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode? #t)))
(printf "Lift...\n") (printf "Lift...\n")
;; Lift functions to aviod closure creation: ;; Lift functions to avoid closure creation:
(define lifted-body (define lifted-body
(time (time
(lift-in-schemified-body body))) (lift-in-schemified-body body)))

15
racket/src/cs/linklet/annotation.ss
View File

@ -10,21 +10,6 @@
[(and (eq? a (car v)) [(and (eq? a (car v))
(eq? d (cdr v))) (eq? d (cdr v)))
(values v v)] (values v v)]
[(and (eq? stripped-a 'letrec*)
(pair? (cdr v)))
(let ([names (let loop ([clauses (cadr v)])
(cond
[(null? clauses) '()]
[else
(let ([id (caar clauses)])
(cons (or (and (correlated? id)
(correlated-property id 'undefined-error-name))
(if (correlated? id)
(correlated-e id)
id))
(loop (cdr clauses))))]))])
(values (list* 'letrec*/names names d)
(list* 'letrec*/names names stripped-d)))]
[else (values (cons a d) [else (values (cons a d)
(cons stripped-a stripped-d))]))] (cons stripped-a stripped-d))]))]
[(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))]) [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))])

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

@ -7,8 +7,6 @@
begin0 begin0
$value $value
letrec*/names
dynamic-wind dynamic-wind
call-with-current-continuation call-with-current-continuation
call-with-composable-continuation call-with-composable-continuation
@ -723,7 +721,6 @@
(include "rumble/virtual-register.ss") (include "rumble/virtual-register.ss")
(include "rumble/layout.ss") (include "rumble/layout.ss")
(include "rumble/begin0.ss") (include "rumble/begin0.ss")
(include "rumble/letrec.ss")
(include "rumble/syntax-rule.ss") (include "rumble/syntax-rule.ss")
(include "rumble/value.ss") (include "rumble/value.ss")
(include "rumble/lock.ss") (include "rumble/lock.ss")

47
racket/src/cs/rumble/letrec.ss
View File

@ -1,47 +0,0 @@
(meta define no-early-reference?
(lambda (stx ids)
(cond
[(#%identifier? stx)
(not (#%ormap (lambda (id) (free-identifier=? id stx)) ids))]
[(let ([d (syntax->datum stx)])
(or (number? d) (boolean? d) (string? d) (bytevector? d)))
#t]
[else
(syntax-case stx (quote |#%name| lambda case-lambda)
[(quote _) #t]
[(|#%name| _ exp) (no-early-reference? #'exp ids)]
[(lambda . _) #t]
[(case-lambda . _) #t]
[_ #f])])))
(meta define no-early-references?
(lambda (rhss ids)
(cond
[(null? rhss) #t]
[else (and (no-early-reference? (car rhss) ids)
(no-early-references? (cdr rhss) (cdr ids)))])))
;; Like `letrec*`, but makes use-before-definition checks explicit so
;; that a source name is included in the error messages. Also, the
;; expansion allows `call/cc`-based capture and multiple return on the
;; right-hand side.
(define-syntax (letrec*/names stx)
(syntax-case stx ()
[(_ (name ...) ([id rhs] ...) body ...)
(cond
[(no-early-references? #'(rhs ...) #'(id ...))
#'(letrec* ([id rhs] ...) body ...)]
[else
(with-syntax ([(tmp-id ...) (generate-temporaries #'(id ...))])
#'(let ([tmp-id unsafe-undefined] ...)
(let-syntax ([id (identifier-syntax
[id (check-not-unsafe-undefined tmp-id 'name)]
[(set! id exp)
(let ([id exp])
(check-not-unsafe-undefined/assign tmp-id 'name)
(set! tmp-id id))])]
...)
(set! tmp-id rhs)
...
(let ()
body ...))))])]))

6
racket/src/schemify/find-definition.rkt
View File

@ -11,7 +11,7 @@
;; Record top-level functions and structure types, and returns ;; Record top-level functions and structure types, and returns
;; (values knowns struct-type-info-or-#f) ;; (values knowns struct-type-info-or-#f)
(define (find-definitions v prim-knowns knowns imports mutated unsafe-mode? (define (find-definitions v prim-knowns knowns imports mutated simples unsafe-mode?
#:optimize? optimize?) #:optimize? optimize?)
(match v (match v
[`(define-values (,id) ,orig-rhs) [`(define-values (,id) ,orig-rhs)
@ -19,7 +19,7 @@
(optimize orig-rhs prim-knowns knowns imports mutated) (optimize orig-rhs prim-knowns knowns imports mutated)
orig-rhs)) orig-rhs))
(values (values
(let ([k (infer-known rhs v #t id knowns prim-knowns imports mutated unsafe-mode? (let ([k (infer-known rhs v #t id knowns prim-knowns imports mutated simples unsafe-mode?
#:optimize-inline? optimize?)]) #:optimize-inline? optimize?)])
(if k (if k
(hash-set knowns (unwrap id) k) (hash-set knowns (unwrap id) k)
@ -118,7 +118,7 @@
[rhs (in-list rhss)]) [rhs (in-list rhss)])
(define-values (new-knowns info) (define-values (new-knowns info)
(find-definitions `(define-values (,id) ,rhs) (find-definitions `(define-values (,id) ,rhs)
prim-knowns knowns imports mutated unsafe-mode? prim-knowns knowns imports mutated simples unsafe-mode?
#:optimize? optimize?)) #:optimize? optimize?))
new-knowns) new-knowns)
#f)] #f)]

4
racket/src/schemify/infer-known.rkt
View File

@ -16,7 +16,7 @@
;; For definitions, it's useful to infer `a-known-constant` to reflect ;; For definitions, it's useful to infer `a-known-constant` to reflect
;; that the variable will get a value without referencing anything ;; that the variable will get a value without referencing anything
;; too early. ;; too early.
(define (infer-known rhs defn rec? id knowns prim-knowns imports mutated unsafe-mode? (define (infer-known rhs defn rec? id knowns prim-knowns imports mutated simples unsafe-mode?
#:optimize-inline? [optimize-inline? #f]) #:optimize-inline? [optimize-inline? #f])
(cond (cond
[(lambda? rhs) [(lambda? rhs)
@ -62,7 +62,7 @@
[(pthread-parameter? rhs prim-knowns knowns mutated) [(pthread-parameter? rhs prim-knowns knowns mutated)
(known-procedure 3)] (known-procedure 3)]
[(and defn [(and defn
(simple? rhs prim-knowns knowns imports mutated)) (simple? rhs prim-knowns knowns imports mutated simples))
a-known-constant] a-known-constant]
[else #f])) [else #f]))

10
racket/src/schemify/left-to-right.rkt
View File

@ -14,7 +14,7 @@
;; expressions that have no shadowing (and introduce ;; expressions that have no shadowing (and introduce
;; shadowing here) ;; shadowing here)
(define (left-to-right/let ids rhss bodys (define (left-to-right/let ids rhss bodys
prim-knowns knowns imports mutated) prim-knowns knowns imports mutated simples)
(cond (cond
[(null? ids) (if (null? (cdr bodys)) [(null? ids) (if (null? (cdr bodys))
(car bodys) (car bodys)
@ -28,7 +28,7 @@
(define id (car ids)) (define id (car ids))
(define rhs (car rhss)) (define rhs (car rhss))
(if (and all-simple? (if (and all-simple?
(simple? rhs prim-knowns knowns imports mutated)) (simple? rhs prim-knowns knowns imports mutated simples))
`(let ([,id ,rhs]) `(let ([,id ,rhs])
. ,bodys) . ,bodys)
`(let ([,id ,rhs]) `(let ([,id ,rhs])
@ -41,7 +41,7 @@
,(loop (cdr ids) ,(loop (cdr ids)
(cdr rhss) (cdr rhss)
(and all-simple? (and all-simple?
(simple? rhs prim-knowns knowns imports mutated)) (simple? rhs prim-knowns knowns imports mutated simples))
(cons `[,id ,id] binds)))]))])) (cons `[,id ,id] binds)))]))]))
;; Convert a `let-values` to nested `let-values`es to ;; Convert a `let-values` to nested `let-values`es to
@ -75,7 +75,7 @@
;; Convert an application to enforce left-to-right ;; Convert an application to enforce left-to-right
;; evaluation order ;; evaluation order
(define (left-to-right/app rator rands plain-app? for-cify? (define (left-to-right/app rator rands plain-app? for-cify?
prim-knowns knowns imports mutated) prim-knowns knowns imports mutated simples)
(cond (cond
[for-cify? (cons rator rands)] [for-cify? (cons rator rands)]
[else [else
@ -98,7 +98,7 @@
(if plain-app? (if plain-app?
app app
`(|#%app| . ,app)))] `(|#%app| . ,app)))]
[(simple? (car l) prim-knowns knowns imports mutated) [(simple? (car l) prim-knowns knowns imports mutated simples)
(loop (cdr l) (cons (car l) accum) pending-non-simple pending-id)] (loop (cdr l) (cons (car l) accum) pending-non-simple pending-id)]
[pending-non-simple [pending-non-simple
`(let ([,pending-id ,pending-non-simple]) `(let ([,pending-id ,pending-non-simple])

28
racket/src/schemify/letrec.rkt
View File

@ -1,9 +1,12 @@
#lang racket/base #lang racket/base
(require "wrap.rkt" (require "wrap.rkt"
"infer-known.rkt") "match.rkt"
"infer-known.rkt"
"mutated-state.rkt")
(provide letrec-splitable-values-binding? (provide letrec-splitable-values-binding?
letrec-split-values-binding) letrec-split-values-binding
letrec-conversion)
;; Detect binding of lambdas that were probably generated from an ;; Detect binding of lambdas that were probably generated from an
;; R[56]RS program ;; R[56]RS program
@ -24,3 +27,24 @@
`[(,id) ,rhs]) `[(,id) ,rhs])
. ,bodys)) . ,bodys))
(define (letrec-conversion ids mutated for-cify? e)
(define need-convert?
(and (not for-cify?)
(let loop ([ids ids])
(cond
[(symbol? ids)
(needs-letrec-convert-mutated-state? (hash-ref mutated ids #f))]
[(wrap? ids) (loop (unwrap ids))]
[(pair? ids) (or (loop (car ids))
(loop (cdr ids)))]
[else #f]))))
(if need-convert?
(match e
[`(,_ ([,ids ,rhss] ...) . ,body)
`(let ,(for/list ([id (in-list ids)])
`[,id unsafe-undefined])
,@(for/list ([id (in-list ids)]
[rhs (in-list rhss)])
`(set! ,id ,rhs))
. ,body)])
e))

62
racket/src/schemify/mutated-state.rkt
View File

@ -5,11 +5,17 @@
;; ;;
;; * 'set!ed - the identifier is `set!`ed ;; * 'set!ed - the identifier is `set!`ed
;; ;;
;; * 'set!ed-too-early - the identifier is `set!`ed potentially
;; before it is initialized
;;
;; * 'implicitly-set!ed - the `letrec`-bound identifier maybe be
;; implicitly `set!`ed via `call/cc`
;;
;; * 'too-early - the identifier may be referenced before it is ;; * 'too-early - the identifier may be referenced before it is
;; defined ;; defined
;; ;;
;; * 'too-early/ready - a variant of 'too-early where the variable ;; * 'too-early/ready - a variant of 'too-early where the variable
;; is now definitely ready ;; is now definitely ready, used only for top levels
;; ;;
;; * 'not-ready - the identifier's value is not yet ready, so a ;; * 'not-ready - the identifier's value is not yet ready, so a
;; reference transitions to 'too-early ;; reference transitions to 'too-early
@ -24,16 +30,24 @@
;; ;;
;; * #f (not mapped) - defined and never `set!`ed ;; * #f (not mapped) - defined and never `set!`ed
;; ;;
;; By the end of the `mutated-in-body` pass, only 'set!ed, 'too-early, ;; By the end of the `mutated-in-body` pass, only 'set!ed,
;; 'not-ready (for exported but not defined) and #f are possible for ;; 'set!ed-too-early, 'implicitly-set!ed, 'too-early,
;; identifiers that are reachable by evaluation. ;; 'too-early/ready, 'not-ready (for exported but not defined) and #f
;; are possible for identifiers that are reachable by evaluation.
(provide delayed-mutated-state? (provide too-early
delayed-mutated-state?
simple-mutated-state? simple-mutated-state?
not-ready-mutated-state? not-ready-mutated-state?
too-early-mutated-state? too-early-mutated-state?
too-early-mutated-state-name
needs-letrec-convert-mutated-state?
via-variable-mutated-state? via-variable-mutated-state?
set!ed-mutated-state?) set!ed-mutated-state?
state->set!ed-state)
;; Used for `letrec` bindings to record a name:
(struct too-early (name set!ed?))
(define (delayed-mutated-state? v) (procedure? v)) (define (delayed-mutated-state? v) (procedure? v))
@ -46,18 +60,44 @@
(eq? v 'not-ready)) (eq? v 'not-ready))
(define (too-early-mutated-state? v) (define (too-early-mutated-state? v)
(eq? v 'too-early)) (or (eq? v 'too-early)
(eq? v 'set!ed-too-early)
(too-early? v)))
;; When referecing an exported identifier, we need to consistently go (define (too-early-mutated-state-name v default-sym)
(if (too-early? v)
(too-early-name v)
default-sym))
(define (needs-letrec-convert-mutated-state? v)
(or (too-early? v)
(eq? v 'too-early)
(eq? v 'too-early/ready)
(eq? v 'implicitly-set!ed)))
;; When referencing an exported identifier, we need to consistently go
;; through a `variable` record when it can be `set!`ed or is not yet ;; through a `variable` record when it can be `set!`ed or is not yet
;; ready (as indicated by 'too-early, which is changed to 'too-eary/ready ;; ready (as indicated by 'too-early, which is changed to 'too-eary/ready
;; as the variable becomes ready) ;; as the variable becomes ready)
(define (via-variable-mutated-state? v) (define (via-variable-mutated-state? v)
(or (eq? v 'set!ed) (or (eq? v 'set!ed)
(eq? v 'undefined) (eq? v 'undefined)
(eq? v 'too-early))) (eq? v 'too-early)
(eq? v 'set!ed-too-early)))
;; At the end of a linklet, known-value information is reliable unless ;; At the end of a linklet, known-value information is reliable unless
;; the identifier is mutated ;; the identifier is explicitly mutated
(define (set!ed-mutated-state? v) (define (set!ed-mutated-state? v)
(eq? v 'set!ed)) (or (eq? v 'set!ed)
(eq? v 'set!ed-too-early)
(and (too-early? v)
(too-early-set!ed? v))))
(define (state->set!ed-state v)
(cond
[(too-early? v)
(struct-copy too-early v [set!ed? #t])]
[(eq? v 'not-ready) 'set!ed-too-early]
[(too-early-mutated-state? v) 'set!ed-too-early]
[(eq? v 'implicitly-set!ed) v]
[else 'set!ed]))

60
racket/src/schemify/mutated.rkt
View File

@ -21,7 +21,10 @@
;; definition of an identifier, because that will abort the enclosing ;; definition of an identifier, because that will abort the enclosing
;; linklet. ;; linklet.
(define (mutated-in-body l exports prim-knowns knowns imports unsafe-mode? enforce-constant?) ;; This pass is also responsible for recording when a letrec binding
;; must be mutated implicitly via `call/cc`.
(define (mutated-in-body l exports prim-knowns knowns imports simples unsafe-mode? enforce-constant?)
;; Find all `set!`ed variables, and also record all bindings ;; Find all `set!`ed variables, and also record all bindings
;; that might be used too early ;; that might be used too early
(define mutated (make-hasheq)) (define mutated (make-hasheq))
@ -50,7 +53,7 @@
;; that information is correct, because it dynamically precedes ;; that information is correct, because it dynamically precedes
;; the `set!` ;; the `set!`
(define-values (knowns info) (define-values (knowns info)
(find-definitions form prim-knowns prev-knowns imports mutated unsafe-mode? (find-definitions form prim-knowns prev-knowns imports mutated simples unsafe-mode?
#:optimize? #f)) #:optimize? #f))
(match form (match form
[`(define-values (,ids ...) ,rhs) [`(define-values (,ids ...) ,rhs)
@ -60,10 +63,10 @@
(for ([e (in-list (struct-type-info-rest info))] (for ([e (in-list (struct-type-info-rest info))]
[pos (in-naturals)]) [pos (in-naturals)])
(unless (and (= pos struct-type-info-rest-properties-list-pos) (unless (and (= pos struct-type-info-rest-properties-list-pos)
(pure-properties-list? e prim-knowns knowns imports mutated)) (pure-properties-list? e prim-knowns knowns imports mutated simples))
(find-mutated! e ids prim-knowns knowns imports mutated)))] (find-mutated! e ids prim-knowns knowns imports mutated simples)))]
[else [else
(find-mutated! rhs ids prim-knowns knowns imports mutated)]) (find-mutated! rhs ids prim-knowns knowns imports mutated simples)])
;; For any among `ids` that didn't get a delay and wasn't used ;; For any among `ids` that didn't get a delay and wasn't used
;; too early, the variable is now ready, so remove from ;; too early, the variable is now ready, so remove from
;; `mutated`: ;; `mutated`:
@ -72,7 +75,7 @@
(when (eq? 'not-ready (hash-ref mutated id #f)) (when (eq? 'not-ready (hash-ref mutated id #f))
(hash-remove! mutated id))))] (hash-remove! mutated id))))]
[`,_ [`,_
(find-mutated! form #f prim-knowns knowns imports mutated)]) (find-mutated! form #f prim-knowns knowns imports mutated simples)])
knowns) knowns)
;; For definitions that are not yet used, force delays: ;; For definitions that are not yet used, force delays:
(for ([form (in-list l)]) (for ([form (in-list l)])
@ -91,7 +94,7 @@
;; Schemify `let-values` to `let`, etc., and ;; Schemify `let-values` to `let`, etc., and
;; reorganize struct bindings. ;; reorganize struct bindings.
(define (find-mutated! v ids prim-knowns knowns imports mutated) (define (find-mutated! v ids prim-knowns knowns imports mutated simples)
(define (delay! ids thunk) (define (delay! ids thunk)
(define done? #f) (define done? #f)
(define force (lambda () (unless done? (define force (lambda () (unless done?
@ -135,14 +138,39 @@
(for* ([ids (in-list idss)] (for* ([ids (in-list idss)]
[id (in-wrap-list ids)]) [id (in-wrap-list ids)])
(hash-set! mutated (unwrap id) 'not-ready)) (hash-set! mutated (unwrap id) 'not-ready))
(for ([ids (in-list idss)] (for/fold ([maybe-cc? #f]) ([ids (in-list idss)]
[rhs (in-list rhss)]) [rhs (in-list rhss)])
(find-mutated! rhs (unwrap-list ids)) (find-mutated! rhs (unwrap-list ids))
(define new-maybe-cc? (or maybe-cc?
(not (simple? rhs prim-knowns knowns imports mutated simples
#:pure? #f))))
;; Each `id` in `ids` is now ready (but might also hold a delay): ;; Each `id` in `ids` is now ready (but might also hold a delay):
(for ([id (in-wrap-list ids)]) (for ([id (in-wrap-list ids)])
(let ([id (unwrap id)]) (let ([u-id (unwrap id)])
(when (eq? 'not-ready (hash-ref mutated id)) (define state (hash-ref mutated u-id))
(hash-remove! mutated id))))) (define (add-too-early-name!)
(cond
[(and (eq? 'too-early state)
(wrap-property id 'undefined-error-name))
=> (lambda (name)
(hash-set! mutated u-id (too-early name #f)))]
[(and (eq? 'set!ed-too-early state)
(wrap-property id 'undefined-error-name))
=> (lambda (name)
(hash-set! mutated u-id (too-early name #t)))]))
(cond
[new-maybe-cc?
(cond
[(or (eq? 'not-ready state)
(delayed-mutated-state? state))
(hash-set! mutated u-id 'implicitly-set!ed)]
[else (add-too-early-name!)])
(when (delayed-mutated-state? state)
(state))]
[(eq? 'not-ready state)
(hash-remove! mutated u-id)]
[else (add-too-early-name!)])))
new-maybe-cc?)
(find-mutated!* bodys ids)])] (find-mutated!* bodys ids)])]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
(find-mutated! tst #f) (find-mutated! tst #f)
@ -160,7 +188,7 @@
[`(set! ,id ,rhs) [`(set! ,id ,rhs)
(let ([id (unwrap id)]) (let ([id (unwrap id)])
(define old-state (hash-ref mutated id #f)) (define old-state (hash-ref mutated id #f))
(hash-set! mutated id 'set!ed) (hash-set! mutated id (state->set!ed-state old-state))
(when (delayed-mutated-state? old-state) (when (delayed-mutated-state? old-state)
(old-state))) (old-state)))
(find-mutated! rhs #f)] (find-mutated! rhs #f)]
@ -174,7 +202,7 @@
(and (known-constructor? v) (and (known-constructor? v)
(bitwise-bit-set? (known-procedure-arity-mask v) (length exps)))) (bitwise-bit-set? (known-procedure-arity-mask v) (length exps))))
(for/and ([exp (in-list exps)]) (for/and ([exp (in-list exps)])
(simple? exp prim-knowns knowns imports mutated))))) (simple? exp prim-knowns knowns imports mutated simples)))))
;; Can delay construction ;; Can delay construction
(delay! ids (lambda () (find-mutated!* exps #f)))] (delay! ids (lambda () (find-mutated!* exps #f)))]
[else [else
@ -216,7 +244,9 @@
[(lambda? rhs #:simple? #t) [(lambda? rhs #:simple? #t)
(for ([id (in-list ids)]) (for ([id (in-list ids)])
(define u-id (unwrap id)) (define u-id (unwrap id))
(when (too-early-mutated-state? (hash-ref mutated u-id #f)) (define state (hash-ref mutated u-id #f))
(when (and (too-early-mutated-state? state)
(not set!ed-mutated-state? state))
(hash-set! mutated u-id 'too-early/ready))) (hash-set! mutated u-id 'too-early/ready)))
(loop (wrap-cdr mut-l))] (loop (wrap-cdr mut-l))]
[else mut-l])] [else mut-l])]

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

@ -191,15 +191,17 @@
(define (schemify-body* l prim-knowns imports exports (define (schemify-body* l prim-knowns imports exports
for-jitify? allow-set!-undefined? add-import! for-jitify? allow-set!-undefined? add-import!
for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt?) for-cify? unsafe-mode? enforce-constant? allow-inline? no-prompt?)
;; Keep simple checking efficient by caching results
(define simples (make-hasheq))
;; Various conversion steps need information about mutated variables, ;; Various conversion steps need information about mutated variables,
;; where "mutated" here includes visible implicit mutation, such as ;; where "mutated" here includes visible implicit mutation, such as
;; a variable that might be used before it is defined: ;; a variable that might be used before it is defined:
(define mutated (mutated-in-body l exports prim-knowns (hasheq) imports unsafe-mode? enforce-constant?)) (define mutated (mutated-in-body l exports prim-knowns (hasheq) imports simples unsafe-mode? enforce-constant?))
;; Make another pass to gather known-binding information: ;; Make another pass to gather known-binding information:
(define knowns (define knowns
(for/fold ([knowns (hasheq)]) ([form (in-list l)]) (for/fold ([knowns (hasheq)]) ([form (in-list l)])
(define-values (new-knowns info) (define-values (new-knowns info)
(find-definitions form prim-knowns knowns imports mutated unsafe-mode? (find-definitions form prim-knowns knowns imports mutated simples unsafe-mode?
#:optimize? #t)) #:optimize? #t))
new-knowns)) new-knowns))
;; For non-exported definitions, we may need to create some variables ;; For non-exported definitions, we may need to create some variables
@ -239,7 +241,7 @@
[else [else
(define form (car l)) (define form (car l))
(define schemified (schemify form (define schemified (schemify form
prim-knowns knowns mutated imports exports prim-knowns knowns mutated imports exports simples
allow-set!-undefined? allow-set!-undefined?
add-import! add-import!
for-cify? for-jitify? for-cify? for-jitify?
@ -307,13 +309,13 @@
(match schemified (match schemified
[`(define ,id ,rhs) [`(define ,id ,rhs)
(cond (cond
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated) [(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples)
(finish-definition (list id))] (finish-definition (list id))]
[else [else
(finish-wrapped-definition (list id) rhs)])] (finish-wrapped-definition (list id) rhs)])]
[`(define-values ,ids ,rhs) [`(define-values ,ids ,rhs)
(cond (cond
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated) [(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples)
(finish-definition ids)] (finish-definition ids)]
[else [else
(finish-wrapped-definition ids rhs)])] (finish-wrapped-definition ids rhs)])]
@ -329,7 +331,7 @@
(finish-definition ids (append set-vars accum-exprs) null)] (finish-definition ids (append set-vars accum-exprs) null)]
[`,_ [`,_
(cond (cond
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated) [(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples)
(loop (wrap-cdr l) mut-l (cons schemified accum-exprs) accum-ids)] (loop (wrap-cdr l) mut-l (cons schemified accum-exprs) accum-ids)]
[else [else
;; In case `schemified` triggers an error, sync exported variables ;; In case `schemified` triggers an error, sync exported variables
@ -376,9 +378,12 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Schemify `let-values` to `let`, etc., and ;; Schemify `let-values` to `let`, etc., and reorganize struct bindings.
;; reorganize struct bindings. ;;
(define (schemify v prim-knowns knowns mutated imports exports allow-set!-undefined? add-import! ;; Non-simple `mutated` state overrides bindings in `knowns`; a
;; a 'too-early state in `mutated` for a `letrec`-bound variable can be
;; effectively canceled with a mapping in `knowns`.
(define (schemify v prim-knowns knowns mutated imports exports simples allow-set!-undefined? add-import!
for-cify? for-jitify? unsafe-mode? allow-inline? no-prompt?) for-cify? for-jitify? unsafe-mode? allow-inline? no-prompt?)
(let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v]) (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v])
(define (schemify v) (define (schemify v)
@ -437,7 +442,7 @@
(define new-knowns (define new-knowns
(for/fold ([knowns knowns]) ([id (in-list ids)] (for/fold ([knowns knowns]) ([id (in-list ids)]
[rhs (in-list rhss)]) [rhs (in-list rhss)])
(define k (infer-known rhs #f #f id knowns prim-knowns imports mutated unsafe-mode?)) (define k (infer-known rhs #f #f id knowns prim-knowns imports mutated simples unsafe-mode?))
(if k (if k
(hash-set knowns (unwrap id) k) (hash-set knowns (unwrap id) k)
knowns))) knowns)))
@ -454,11 +459,11 @@
(schemify rhs)) (schemify rhs))
(for/list ([body (in-list bodys)]) (for/list ([body (in-list bodys)])
(schemify/knowns new-knowns inline-fuel body)) (schemify/knowns new-knowns inline-fuel body))
prim-knowns knowns imports mutated)] prim-knowns knowns imports mutated simples)]
[`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...) [`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...)
`(begin ,@(schemify-body rhss) ,@(schemify-body bodys))] `(begin ,@(schemify-body rhss) ,@(schemify-body bodys))]
[`(let-values ([,idss ,rhss] ...) ,bodys ...) [`(let-values ([,idss ,rhss] ...) ,bodys ...)
(or (struct-convert-local v prim-knowns knowns imports mutated (or (struct-convert-local v prim-knowns knowns imports mutated simples
(lambda (v knowns) (schemify/knowns knowns inline-fuel v)) (lambda (v knowns) (schemify/knowns knowns inline-fuel v))
#:unsafe-mode? unsafe-mode?) #:unsafe-mode? unsafe-mode?)
(left-to-right/let-values idss (left-to-right/let-values idss
@ -475,21 +480,26 @@
;; special case of splitable values: ;; special case of splitable values:
(schemify `(letrec-values ([(,id) ,rhs]) . ,bodys))] (schemify `(letrec-values ([(,id) ,rhs]) . ,bodys))]
[`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...) [`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...)
(define new-knowns (define-values (rhs-knowns body-knowns)
(for/fold ([knowns knowns]) ([id (in-list ids)] (for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)]
[rhs (in-list rhss)]) [rhs (in-list rhss)])
(define k (infer-known rhs #f #t id knowns prim-knowns imports mutated unsafe-mode?)) (define k (infer-known rhs #f #t id knowns prim-knowns imports mutated simples unsafe-mode?))
(if k (define u-id (unwrap id))
(hash-set knowns (unwrap id) k) (cond
knowns))) [(too-early-mutated-state? (hash-ref mutated u-id #f))
`(letrec* ,(for/list ([id (in-list ids)] (values rhs-knowns (hash-set knowns u-id (or k a-known-constant)))]
[rhs (in-list rhss)]) [k (values (hash-set rhs-knowns u-id k) (hash-set body-knowns u-id k))]
`[,id ,(schemify/knowns new-knowns inline-fuel rhs)]) [else (values rhs-knowns body-knowns)])))
,@(for/list ([body (in-list bodys)]) (letrec-conversion
(schemify/knowns new-knowns inline-fuel body)))] ids mutated for-cify?
`(letrec* ,(for/list ([id (in-list ids)]
[rhs (in-list rhss)])
`[,id ,(schemify/knowns rhs-knowns inline-fuel rhs)])
,@(for/list ([body (in-list bodys)])
(schemify/knowns body-knowns inline-fuel body))))]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...) [`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
(cond (cond
[(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated [(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated simples
(lambda (v knowns) (schemify/knowns knowns inline-fuel v)) (lambda (v knowns) (schemify/knowns knowns inline-fuel v))
#:unsafe-mode? unsafe-mode?) #:unsafe-mode? unsafe-mode?)
=> (lambda (form) form)] => (lambda (form) form)]
@ -504,24 +514,26 @@
;; [id (vector-ref vec 0)] ;; [id (vector-ref vec 0)]
;; ... ...) ;; ... ...)
;; ....) ;; ....)
`(letrec* ,(apply (letrec-conversion
append idss mutated for-cify?
(for/list ([ids (in-wrap-list idss)] `(letrec* ,(apply
[rhs (in-list rhss)]) append
(let ([rhs (schemify rhs)]) (for/list ([ids (in-wrap-list idss)]
(cond [rhs (in-list rhss)])
[(null? ids) (let ([rhs (schemify rhs)])
`([,(gensym "lr") (cond
,(make-let-values null rhs '(void) for-cify?)])] [(null? ids)
[(and (pair? ids) (null? (cdr ids))) `([,(gensym "lr")
`([,(car ids) ,rhs])] ,(make-let-values null rhs '(void) for-cify?)])]
[else [(and (pair? ids) (null? (cdr ids)))
(define lr (gensym "lr")) `([,(car ids) ,rhs])]
`([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)] [else
,@(for/list ([id (in-list ids)] (define lr (gensym "lr"))
[pos (in-naturals)]) `([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)]
`[,id (unsafe-vector*-ref ,lr ,pos)]))])))) ,@(for/list ([id (in-list ids)]
,@(schemify-body bodys))])] [pos (in-naturals)])
`[,id (unsafe-vector*-ref ,lr ,pos)]))]))))
,@(schemify-body bodys)))])]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
`(if ,(schemify tst) ,(schemify thn) ,(schemify els))] `(if ,(schemify tst) ,(schemify thn) ,(schemify els))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark ,key ,val ,body)
@ -535,9 +547,21 @@
[`(set! ,id ,rhs) [`(set! ,id ,rhs)
(define int-id (unwrap id)) (define int-id (unwrap id))
(define ex (hash-ref exports int-id #f)) (define ex (hash-ref exports int-id #f))
(if ex (define new-rhs (schemify rhs))
`(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,(schemify rhs) '#f) (cond
`(set! ,id ,(schemify rhs)))] [ex
`(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,new-rhs '#f)]
[else
(define state (hash-ref mutated int-id #f))
(cond
[(and (too-early-mutated-state? state)
(not for-cify?))
(define tmp (gensym 'set))
`(let ([,tmp ,new-rhs])
(check-not-unsafe-undefined/assign ,id ',(too-early-mutated-state-name state int-id))
(set! ,id ,tmp))]
[else
`(set! ,id ,new-rhs)])])]
[`(variable-reference-constant? (#%variable-reference ,id)) [`(variable-reference-constant? (#%variable-reference ,id))
(define u-id (unwrap id)) (define u-id (unwrap id))
(cond (cond
@ -585,7 +609,7 @@
(left-to-right/app 'equal? (left-to-right/app 'equal?
(list exp1 exp2) (list exp1 exp2)
#t for-cify? #t for-cify?
prim-knowns knowns imports mutated)]))] prim-knowns knowns imports mutated simples)]))]
[`(call-with-values ,generator ,receiver) [`(call-with-values ,generator ,receiver)
(cond (cond
[(and (lambda? generator) [(and (lambda? generator)
@ -595,7 +619,7 @@
(left-to-right/app (if for-cify? 'call-with-values '#%call-with-values) (left-to-right/app (if for-cify? 'call-with-values '#%call-with-values)
(list (schemify generator) (schemify receiver)) (list (schemify generator) (schemify receiver))
#t for-cify? #t for-cify?
prim-knowns knowns imports mutated)])] prim-knowns knowns imports mutated simples)])]
[`((letrec-values ,binds ,rator) ,rands ...) [`((letrec-values ,binds ,rator) ,rands ...)
(schemify `(letrec-values ,binds (,rator . ,rands)))] (schemify `(letrec-values ,binds (,rator . ,rands)))]
[`(,rator ,exps ...) [`(,rator ,exps ...)
@ -693,7 +717,7 @@
(left-to-right/app (car e) (left-to-right/app (car e)
(cdr e) (cdr e)
#t for-cify? #t for-cify?
prim-knowns knowns imports mutated))] prim-knowns knowns imports mutated simples))]
[(and (not for-cify?) [(and (not for-cify?)
(known-field-accessor? k) (known-field-accessor? k)
(inline-field-access k s-rator im args)) (inline-field-access k s-rator im args))
@ -707,14 +731,14 @@
(left-to-right/app (known-procedure/has-unsafe-alternate k) (left-to-right/app (known-procedure/has-unsafe-alternate k)
args args
#t for-cify? #t for-cify?
prim-knowns knowns imports mutated)] prim-knowns knowns imports mutated simples)]
[else [else
(define plain-app? (or (known-procedure? k) (define plain-app? (or (known-procedure? k)
(lambda? rator))) (lambda? rator)))
(left-to-right/app s-rator (left-to-right/app s-rator
args args
plain-app? for-cify? plain-app? for-cify?
prim-knowns knowns imports mutated)])))] prim-knowns knowns imports mutated simples)])))]
[`,_ [`,_
(let ([u-v (unwrap v)]) (let ([u-v (unwrap v)])
(cond (cond
@ -722,38 +746,46 @@
v] v]
[(eq? u-v 'call-with-values) [(eq? u-v 'call-with-values)
'#%call-with-values] '#%call-with-values]
[(and (via-variable-mutated-state? (hash-ref mutated u-v #f)) [else
(hash-ref exports u-v #f)) (define state (hash-ref mutated u-v #f))
=> (lambda (ex) `(variable-ref ,(export-id ex)))] (cond
[(hash-ref imports u-v #f) [(and (via-variable-mutated-state? state)
=> (lambda (im) (hash-ref exports u-v #f))
(define k (import-lookup im)) => (lambda (ex) `(variable-ref ,(export-id ex)))]
(if (known-constant? k) [(hash-ref imports u-v #f)
;; Not boxed: => (lambda (im)
(cond (define k (import-lookup im))
[(known-literal? k) (if (known-constant? k)
;; We'd normally leave this to `optimize`, but ;; Not boxed:
;; need to handle it here before generating a (cond
;; reference to the renamed identifier [(known-literal? k)
(known-literal-expr k)] ;; We'd normally leave this to `optimize`, but
[(and (known-copy? k) ;; need to handle it here before generating a
(hash-ref prim-knowns (known-copy-id k) #f)) ;; reference to the renamed identifier
;; Directly reference primitive (known-literal-expr k)]
(known-copy-id k)] [(and (known-copy? k)
[else (hash-ref prim-knowns (known-copy-id k) #f))
(import-id im)]) ;; Directly reference primitive
;; Will be boxed, but won't be undefined (because the (known-copy-id k)]
;; module system won't link to an instance whose [else
;; definitions didn't complete): (import-id im)])
`(variable-ref/no-check ,(import-id im))))] ;; Will be boxed, but won't be undefined (because the
[(hash-ref knowns u-v #f) ;; module system won't link to an instance whose
=> (lambda (k) ;; definitions didn't complete):
(cond `(variable-ref/no-check ,(import-id im))))]
[(and (known-copy? k) [(hash-ref knowns u-v #f)
(simple-mutated-state? (hash-ref mutated u-v #f))) => (lambda (k)
(schemify (known-copy-id k))] (cond
[else v]))] [(and (known-copy? k)
[else v]))]))) (simple-mutated-state? (hash-ref mutated u-v #f)))
(schemify (known-copy-id k))]
[else v]))]
[(and (too-early-mutated-state? state)
(not for-cify?))
;; Note: we don't get to this case if `knowns` has
;; a mapping that says the variable is ready by now
`(check-not-unsafe-undefined ,v ',(too-early-mutated-state-name state u-v))]
[else v])]))])))
(optimize s-v prim-knowns knowns imports mutated)) (optimize s-v prim-knowns knowns imports mutated))
(define (schemify-body l) (define (schemify-body l)

66
racket/src/schemify/simple.rkt
View File

@ -11,46 +11,60 @@
;; Check whether an expression is simple in the sense that its order ;; Check whether an expression is simple in the sense that its order
;; of evaluation isn't detectable. This function receives both ;; of evaluation isn't detectable. This function receives both
;; schemified and non-schemified expressions. ;; schemified and non-schemified expressions.
(define (simple? e prim-knowns knowns imports mutated (define (simple? e prim-knowns knowns imports mutated simples
#:pure? [pure? #t]) #:pure? [pure? #t])
(let simple? ([e e]) (let simple? ([e e])
(define-syntax-rule (cached expr)
(let* ([c (hash-ref simples e '(unknown . unknown))]
[r (if pure? (car c) (cdr c))])
(if (eq? 'unknown r)
(let ([r expr])
(hash-set! simples e (if pure? (cons r (cdr c)) (cons (car c) r)))
r)
r)))
(match e (match e
[`(lambda . ,_) #t] [`(lambda . ,_) #t]
[`(case-lambda . ,_) #t] [`(case-lambda . ,_) #t]
[`(quote . ,_) #t] [`(quote . ,_) #t]
[`(#%variable-reference . ,_) #t] [`(#%variable-reference . ,_) #t]
[`(let-values ([,_ ,rhss] ...) ,body) [`(let-values ([,_ ,rhss] ...) ,body)
(and (for/and ([rhs (in-list rhss)]) (cached
(simple? rhs)) (and (for/and ([rhs (in-list rhss)])
(simple? body))] (simple? rhs))
(simple? body)))]
[`(let ([,_ ,rhss] ...) ,body) [`(let ([,_ ,rhss] ...) ,body)
(and (for/and ([rhs (in-list rhss)]) (cached
(simple? rhs)) (and (for/and ([rhs (in-list rhss)])
(simple? body))] (simple? rhs))
(simple? body)))]
[`(letrec-values ([(,idss ...) ,rhss] ...) ,body) [`(letrec-values ([(,idss ...) ,rhss] ...) ,body)
(and (for/and ([rhs (in-list rhss)]) (cached
(simple? rhs)) (and (for/and ([rhs (in-list rhss)])
(simple? body))] (simple? rhs))
(simple? body)))]
[`(letrec* ([,ids ,rhss] ...) ,body) [`(letrec* ([,ids ,rhss] ...) ,body)
(and (for/and ([rhs (in-list rhss)]) (cached
(simple? rhs)) (and (for/and ([rhs (in-list rhss)])
(simple? body))] (simple? rhs))
(simple? body)))]
[`(begin ,es ...) [`(begin ,es ...)
#:guard (not pure?) #:guard (not pure?)
(for/and ([e (in-list es)]) (cached
(simple? e))] (for/and ([e (in-list es)])
(simple? e)))]
[`(,proc . ,args) [`(,proc . ,args)
(let ([proc (unwrap proc)]) (cached
(and (symbol? proc) (let ([proc (unwrap proc)])
(let ([v (or (hash-ref-either knowns imports proc) (and (symbol? proc)
(hash-ref prim-knowns proc #f))]) (let ([v (or (hash-ref-either knowns imports proc)
(and (if pure? (hash-ref prim-knowns proc #f))])
(known-procedure/pure? v) (and (if pure?
(known-procedure/succeeds? v)) (known-procedure/pure? v)
(bitwise-bit-set? (known-procedure-arity-mask v) (length args)))) (known-procedure/succeeds? v))
(simple-mutated-state? (hash-ref mutated proc #f)) (bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
(for/and ([arg (in-list args)]) (simple-mutated-state? (hash-ref mutated proc #f))
(simple? arg))))] (for/and ([arg (in-list args)])
(simple? arg)))))]
[`,_ [`,_
(let ([e (unwrap e)]) (let ([e (unwrap e)])
(or (and (symbol? e) (or (and (symbol? e)

4
racket/src/schemify/struct-convert.rkt
View File

@ -150,7 +150,7 @@
[`,_ #f])) [`,_ #f]))
(define (struct-convert-local form #:letrec? [letrec? #f] (define (struct-convert-local form #:letrec? [letrec? #f]
prim-knowns knowns imports mutated prim-knowns knowns imports mutated simples
schemify schemify
#:unsafe-mode? unsafe-mode?) #:unsafe-mode? unsafe-mode?)
(match form (match form
@ -164,7 +164,7 @@
(match new-seq (match new-seq
[`(begin . ,new-seq) [`(begin . ,new-seq)
(define-values (new-knowns info) (define-values (new-knowns info)
(find-definitions defn prim-knowns knowns imports mutated unsafe-mode? (find-definitions defn prim-knowns knowns imports mutated simples unsafe-mode?
#:optimize? #f)) #:optimize? #f))
(cond (cond
[letrec? [letrec?

4
racket/src/schemify/struct-type-info.rkt
View File

@ -87,7 +87,7 @@
;; Check whether `e` has the shape of a property list that uses only ;; Check whether `e` has the shape of a property list that uses only
;; properties where the property doesn't have a guard or won't invoke ;; properties where the property doesn't have a guard or won't invoke
;; a guarded procedure ;; a guarded procedure
(define (pure-properties-list? e prim-knowns knowns imports mutated) (define (pure-properties-list? e prim-knowns knowns imports mutated simples)
(match e (match e
[`(list (cons ,props ,vals) ...) [`(list (cons ,props ,vals) ...)
(for/and ([prop (in-list props)] (for/and ([prop (in-list props)]
@ -96,7 +96,7 @@
(and (symbol? u-prop) (and (symbol? u-prop)
(or (known-struct-type-property/immediate-guard? (or (known-struct-type-property/immediate-guard?
(find-known u-prop prim-knowns knowns imports mutated))) (find-known u-prop prim-knowns knowns imports mutated)))
(simple? val prim-knowns knowns imports mutated))))] (simple? val prim-knowns knowns imports mutated simples))))]
[`null #t] [`null #t]
[`'() #t] [`'() #t]
[`,_ #f])) [`,_ #f]))