cs: move letrec conversion to schemify
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
parent
fe708871bd
commit
9d3a49f265
|
|
@ -245,7 +245,6 @@ RUMBLE_SRCS = rumble/define.ss \
|
|||
rumble/layout.ss \
|
||||
rumble/check.ss \
|
||||
rumble/syntax-rule.ss \
|
||||
rumble/letrec.ss \
|
||||
rumble/constant.ss \
|
||||
rumble/hash-code.ss \
|
||||
rumble/struct.ss \
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@
|
|||
(time
|
||||
(schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq() for-cify? unsafe-mode? #t)))
|
||||
(printf "Lift...\n")
|
||||
;; Lift functions to aviod closure creation:
|
||||
;; Lift functions to avoid closure creation:
|
||||
(define lifted-body
|
||||
(time
|
||||
(lift-in-schemified-body body)))
|
||||
|
|
|
|||
|
|
@ -10,21 +10,6 @@
|
|||
[(and (eq? a (car v))
|
||||
(eq? d (cdr 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)
|
||||
(cons stripped-a stripped-d))]))]
|
||||
[(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))])
|
||||
|
|
|
|||
|
|
@ -7,8 +7,6 @@
|
|||
begin0
|
||||
$value
|
||||
|
||||
letrec*/names
|
||||
|
||||
dynamic-wind
|
||||
call-with-current-continuation
|
||||
call-with-composable-continuation
|
||||
|
|
@ -723,7 +721,6 @@
|
|||
(include "rumble/virtual-register.ss")
|
||||
(include "rumble/layout.ss")
|
||||
(include "rumble/begin0.ss")
|
||||
(include "rumble/letrec.ss")
|
||||
(include "rumble/syntax-rule.ss")
|
||||
(include "rumble/value.ss")
|
||||
(include "rumble/lock.ss")
|
||||
|
|
|
|||
|
|
@ -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 ...))))])]))
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
|
||||
;; Record top-level functions and structure types, and returns
|
||||
;; (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?)
|
||||
(match v
|
||||
[`(define-values (,id) ,orig-rhs)
|
||||
|
|
@ -19,7 +19,7 @@
|
|||
(optimize orig-rhs prim-knowns knowns imports mutated)
|
||||
orig-rhs))
|
||||
(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?)])
|
||||
(if k
|
||||
(hash-set knowns (unwrap id) k)
|
||||
|
|
@ -118,7 +118,7 @@
|
|||
[rhs (in-list rhss)])
|
||||
(define-values (new-knowns info)
|
||||
(find-definitions `(define-values (,id) ,rhs)
|
||||
prim-knowns knowns imports mutated unsafe-mode?
|
||||
prim-knowns knowns imports mutated simples unsafe-mode?
|
||||
#:optimize? optimize?))
|
||||
new-knowns)
|
||||
#f)]
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@
|
|||
;; For definitions, it's useful to infer `a-known-constant` to reflect
|
||||
;; that the variable will get a value without referencing anything
|
||||
;; 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])
|
||||
(cond
|
||||
[(lambda? rhs)
|
||||
|
|
@ -62,7 +62,7 @@
|
|||
[(pthread-parameter? rhs prim-knowns knowns mutated)
|
||||
(known-procedure 3)]
|
||||
[(and defn
|
||||
(simple? rhs prim-knowns knowns imports mutated))
|
||||
(simple? rhs prim-knowns knowns imports mutated simples))
|
||||
a-known-constant]
|
||||
[else #f]))
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
;; expressions that have no shadowing (and introduce
|
||||
;; shadowing here)
|
||||
(define (left-to-right/let ids rhss bodys
|
||||
prim-knowns knowns imports mutated)
|
||||
prim-knowns knowns imports mutated simples)
|
||||
(cond
|
||||
[(null? ids) (if (null? (cdr bodys))
|
||||
(car bodys)
|
||||
|
|
@ -28,7 +28,7 @@
|
|||
(define id (car ids))
|
||||
(define rhs (car rhss))
|
||||
(if (and all-simple?
|
||||
(simple? rhs prim-knowns knowns imports mutated))
|
||||
(simple? rhs prim-knowns knowns imports mutated simples))
|
||||
`(let ([,id ,rhs])
|
||||
. ,bodys)
|
||||
`(let ([,id ,rhs])
|
||||
|
|
@ -41,7 +41,7 @@
|
|||
,(loop (cdr ids)
|
||||
(cdr rhss)
|
||||
(and all-simple?
|
||||
(simple? rhs prim-knowns knowns imports mutated))
|
||||
(simple? rhs prim-knowns knowns imports mutated simples))
|
||||
(cons `[,id ,id] binds)))]))]))
|
||||
|
||||
;; Convert a `let-values` to nested `let-values`es to
|
||||
|
|
@ -75,7 +75,7 @@
|
|||
;; Convert an application to enforce left-to-right
|
||||
;; evaluation order
|
||||
(define (left-to-right/app rator rands plain-app? for-cify?
|
||||
prim-knowns knowns imports mutated)
|
||||
prim-knowns knowns imports mutated simples)
|
||||
(cond
|
||||
[for-cify? (cons rator rands)]
|
||||
[else
|
||||
|
|
@ -98,7 +98,7 @@
|
|||
(if plain-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)]
|
||||
[pending-non-simple
|
||||
`(let ([,pending-id ,pending-non-simple])
|
||||
|
|
|
|||
|
|
@ -1,9 +1,12 @@
|
|||
#lang racket/base
|
||||
(require "wrap.rkt"
|
||||
"infer-known.rkt")
|
||||
"match.rkt"
|
||||
"infer-known.rkt"
|
||||
"mutated-state.rkt")
|
||||
|
||||
(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
|
||||
;; R[56]RS program
|
||||
|
|
@ -24,3 +27,24 @@
|
|||
`[(,id) ,rhs])
|
||||
. ,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))
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
schemify-body
|
||||
|
||||
(all-from-out "known.rkt")
|
||||
|
||||
|
||||
lift-in-schemified-linklet
|
||||
lift-in-schemified-body
|
||||
|
||||
|
|
|
|||
|
|
@ -5,11 +5,17 @@
|
|||
;;
|
||||
;; * '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
|
||||
;; defined
|
||||
;;
|
||||
;; * '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
|
||||
;; reference transitions to 'too-early
|
||||
|
|
@ -24,16 +30,24 @@
|
|||
;;
|
||||
;; * #f (not mapped) - defined and never `set!`ed
|
||||
;;
|
||||
;; By the end of the `mutated-in-body` pass, only 'set!ed, 'too-early,
|
||||
;; 'not-ready (for exported but not defined) and #f are possible for
|
||||
;; identifiers that are reachable by evaluation.
|
||||
;; By the end of the `mutated-in-body` pass, only 'set!ed,
|
||||
;; 'set!ed-too-early, 'implicitly-set!ed, 'too-early,
|
||||
;; '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?
|
||||
not-ready-mutated-state?
|
||||
too-early-mutated-state?
|
||||
too-early-mutated-state-name
|
||||
needs-letrec-convert-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))
|
||||
|
||||
|
|
@ -46,18 +60,44 @@
|
|||
(eq? v 'not-ready))
|
||||
|
||||
(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
|
||||
;; ready (as indicated by 'too-early, which is changed to 'too-eary/ready
|
||||
;; as the variable becomes ready)
|
||||
(define (via-variable-mutated-state? v)
|
||||
(or (eq? v 'set!ed)
|
||||
(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
|
||||
;; the identifier is mutated
|
||||
;; the identifier is explicitly mutated
|
||||
(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]))
|
||||
|
|
|
|||
|
|
@ -21,7 +21,10 @@
|
|||
;; definition of an identifier, because that will abort the enclosing
|
||||
;; 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
|
||||
;; that might be used too early
|
||||
(define mutated (make-hasheq))
|
||||
|
|
@ -50,7 +53,7 @@
|
|||
;; that information is correct, because it dynamically precedes
|
||||
;; the `set!`
|
||||
(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))
|
||||
(match form
|
||||
[`(define-values (,ids ...) ,rhs)
|
||||
|
|
@ -60,10 +63,10 @@
|
|||
(for ([e (in-list (struct-type-info-rest info))]
|
||||
[pos (in-naturals)])
|
||||
(unless (and (= pos struct-type-info-rest-properties-list-pos)
|
||||
(pure-properties-list? e prim-knowns knowns imports mutated))
|
||||
(find-mutated! e ids prim-knowns knowns imports mutated)))]
|
||||
(pure-properties-list? e prim-knowns knowns imports mutated simples))
|
||||
(find-mutated! e ids prim-knowns knowns imports mutated simples)))]
|
||||
[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
|
||||
;; too early, the variable is now ready, so remove from
|
||||
;; `mutated`:
|
||||
|
|
@ -72,7 +75,7 @@
|
|||
(when (eq? 'not-ready (hash-ref mutated id #f))
|
||||
(hash-remove! mutated id))))]
|
||||
[`,_
|
||||
(find-mutated! form #f prim-knowns knowns imports mutated)])
|
||||
(find-mutated! form #f prim-knowns knowns imports mutated simples)])
|
||||
knowns)
|
||||
;; For definitions that are not yet used, force delays:
|
||||
(for ([form (in-list l)])
|
||||
|
|
@ -91,7 +94,7 @@
|
|||
|
||||
;; Schemify `let-values` to `let`, etc., and
|
||||
;; 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 done? #f)
|
||||
(define force (lambda () (unless done?
|
||||
|
|
@ -135,14 +138,39 @@
|
|||
(for* ([ids (in-list idss)]
|
||||
[id (in-wrap-list ids)])
|
||||
(hash-set! mutated (unwrap id) 'not-ready))
|
||||
(for ([ids (in-list idss)]
|
||||
[rhs (in-list rhss)])
|
||||
(for/fold ([maybe-cc? #f]) ([ids (in-list idss)]
|
||||
[rhs (in-list rhss)])
|
||||
(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):
|
||||
(for ([id (in-wrap-list ids)])
|
||||
(let ([id (unwrap id)])
|
||||
(when (eq? 'not-ready (hash-ref mutated id))
|
||||
(hash-remove! mutated id)))))
|
||||
(let ([u-id (unwrap id)])
|
||||
(define state (hash-ref mutated u-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)])]
|
||||
[`(if ,tst ,thn ,els)
|
||||
(find-mutated! tst #f)
|
||||
|
|
@ -160,7 +188,7 @@
|
|||
[`(set! ,id ,rhs)
|
||||
(let ([id (unwrap id)])
|
||||
(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)
|
||||
(old-state)))
|
||||
(find-mutated! rhs #f)]
|
||||
|
|
@ -174,7 +202,7 @@
|
|||
(and (known-constructor? v)
|
||||
(bitwise-bit-set? (known-procedure-arity-mask v) (length 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
|
||||
(delay! ids (lambda () (find-mutated!* exps #f)))]
|
||||
[else
|
||||
|
|
@ -216,7 +244,9 @@
|
|||
[(lambda? rhs #:simple? #t)
|
||||
(for ([id (in-list ids)])
|
||||
(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)))
|
||||
(loop (wrap-cdr mut-l))]
|
||||
[else mut-l])]
|
||||
|
|
|
|||
|
|
@ -191,15 +191,17 @@
|
|||
(define (schemify-body* l prim-knowns imports exports
|
||||
for-jitify? allow-set!-undefined? add-import!
|
||||
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,
|
||||
;; where "mutated" here includes visible implicit mutation, such as
|
||||
;; 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:
|
||||
(define knowns
|
||||
(for/fold ([knowns (hasheq)]) ([form (in-list l)])
|
||||
(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))
|
||||
new-knowns))
|
||||
;; For non-exported definitions, we may need to create some variables
|
||||
|
|
@ -239,7 +241,7 @@
|
|||
[else
|
||||
(define form (car l))
|
||||
(define schemified (schemify form
|
||||
prim-knowns knowns mutated imports exports
|
||||
prim-knowns knowns mutated imports exports simples
|
||||
allow-set!-undefined?
|
||||
add-import!
|
||||
for-cify? for-jitify?
|
||||
|
|
@ -307,13 +309,13 @@
|
|||
(match schemified
|
||||
[`(define ,id ,rhs)
|
||||
(cond
|
||||
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated)
|
||||
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples)
|
||||
(finish-definition (list id))]
|
||||
[else
|
||||
(finish-wrapped-definition (list id) rhs)])]
|
||||
[`(define-values ,ids ,rhs)
|
||||
(cond
|
||||
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated)
|
||||
[(simple? #:pure? #f rhs prim-knowns knowns imports mutated simples)
|
||||
(finish-definition ids)]
|
||||
[else
|
||||
(finish-wrapped-definition ids rhs)])]
|
||||
|
|
@ -329,7 +331,7 @@
|
|||
(finish-definition ids (append set-vars accum-exprs) null)]
|
||||
[`,_
|
||||
(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)]
|
||||
[else
|
||||
;; In case `schemified` triggers an error, sync exported variables
|
||||
|
|
@ -376,9 +378,12 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Schemify `let-values` to `let`, etc., and
|
||||
;; reorganize struct bindings.
|
||||
(define (schemify v prim-knowns knowns mutated imports exports allow-set!-undefined? add-import!
|
||||
;; Schemify `let-values` to `let`, etc., and reorganize struct bindings.
|
||||
;;
|
||||
;; 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?)
|
||||
(let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [v v])
|
||||
(define (schemify v)
|
||||
|
|
@ -437,7 +442,7 @@
|
|||
(define new-knowns
|
||||
(for/fold ([knowns knowns]) ([id (in-list ids)]
|
||||
[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
|
||||
(hash-set knowns (unwrap id) k)
|
||||
knowns)))
|
||||
|
|
@ -454,11 +459,11 @@
|
|||
(schemify rhs))
|
||||
(for/list ([body (in-list bodys)])
|
||||
(schemify/knowns new-knowns inline-fuel body))
|
||||
prim-knowns knowns imports mutated)]
|
||||
prim-knowns knowns imports mutated simples)]
|
||||
[`(let-values ([() (begin ,rhss ... (values))]) ,bodys ...)
|
||||
`(begin ,@(schemify-body rhss) ,@(schemify-body 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))
|
||||
#:unsafe-mode? unsafe-mode?)
|
||||
(left-to-right/let-values idss
|
||||
|
|
@ -475,21 +480,26 @@
|
|||
;; special case of splitable values:
|
||||
(schemify `(letrec-values ([(,id) ,rhs]) . ,bodys))]
|
||||
[`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...)
|
||||
(define new-knowns
|
||||
(for/fold ([knowns knowns]) ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
(define k (infer-known rhs #f #t id knowns prim-knowns imports mutated unsafe-mode?))
|
||||
(if k
|
||||
(hash-set knowns (unwrap id) k)
|
||||
knowns)))
|
||||
`(letrec* ,(for/list ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
`[,id ,(schemify/knowns new-knowns inline-fuel rhs)])
|
||||
,@(for/list ([body (in-list bodys)])
|
||||
(schemify/knowns new-knowns inline-fuel body)))]
|
||||
(define-values (rhs-knowns body-knowns)
|
||||
(for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
(define k (infer-known rhs #f #t id knowns prim-knowns imports mutated simples unsafe-mode?))
|
||||
(define u-id (unwrap id))
|
||||
(cond
|
||||
[(too-early-mutated-state? (hash-ref mutated u-id #f))
|
||||
(values rhs-knowns (hash-set knowns u-id (or k a-known-constant)))]
|
||||
[k (values (hash-set rhs-knowns u-id k) (hash-set body-knowns u-id k))]
|
||||
[else (values rhs-knowns body-knowns)])))
|
||||
(letrec-conversion
|
||||
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 ...)
|
||||
(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))
|
||||
#:unsafe-mode? unsafe-mode?)
|
||||
=> (lambda (form) form)]
|
||||
|
|
@ -504,24 +514,26 @@
|
|||
;; [id (vector-ref vec 0)]
|
||||
;; ... ...)
|
||||
;; ....)
|
||||
`(letrec* ,(apply
|
||||
append
|
||||
(for/list ([ids (in-wrap-list idss)]
|
||||
[rhs (in-list rhss)])
|
||||
(let ([rhs (schemify rhs)])
|
||||
(cond
|
||||
[(null? ids)
|
||||
`([,(gensym "lr")
|
||||
,(make-let-values null rhs '(void) for-cify?)])]
|
||||
[(and (pair? ids) (null? (cdr ids)))
|
||||
`([,(car ids) ,rhs])]
|
||||
[else
|
||||
(define lr (gensym "lr"))
|
||||
`([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)]
|
||||
,@(for/list ([id (in-list ids)]
|
||||
[pos (in-naturals)])
|
||||
`[,id (unsafe-vector*-ref ,lr ,pos)]))]))))
|
||||
,@(schemify-body bodys))])]
|
||||
(letrec-conversion
|
||||
idss mutated for-cify?
|
||||
`(letrec* ,(apply
|
||||
append
|
||||
(for/list ([ids (in-wrap-list idss)]
|
||||
[rhs (in-list rhss)])
|
||||
(let ([rhs (schemify rhs)])
|
||||
(cond
|
||||
[(null? ids)
|
||||
`([,(gensym "lr")
|
||||
,(make-let-values null rhs '(void) for-cify?)])]
|
||||
[(and (pair? ids) (null? (cdr ids)))
|
||||
`([,(car ids) ,rhs])]
|
||||
[else
|
||||
(define lr (gensym "lr"))
|
||||
`([,lr ,(make-let-values ids rhs `(vector . ,ids) for-cify?)]
|
||||
,@(for/list ([id (in-list ids)]
|
||||
[pos (in-naturals)])
|
||||
`[,id (unsafe-vector*-ref ,lr ,pos)]))]))))
|
||||
,@(schemify-body bodys)))])]
|
||||
[`(if ,tst ,thn ,els)
|
||||
`(if ,(schemify tst) ,(schemify thn) ,(schemify els))]
|
||||
[`(with-continuation-mark ,key ,val ,body)
|
||||
|
|
@ -535,9 +547,21 @@
|
|||
[`(set! ,id ,rhs)
|
||||
(define int-id (unwrap id))
|
||||
(define ex (hash-ref exports int-id #f))
|
||||
(if ex
|
||||
`(,(if allow-set!-undefined? 'variable-set! 'variable-set!/check-undefined) ,(export-id ex) ,(schemify rhs) '#f)
|
||||
`(set! ,id ,(schemify rhs)))]
|
||||
(define new-rhs (schemify rhs))
|
||||
(cond
|
||||
[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))
|
||||
(define u-id (unwrap id))
|
||||
(cond
|
||||
|
|
@ -585,7 +609,7 @@
|
|||
(left-to-right/app 'equal?
|
||||
(list exp1 exp2)
|
||||
#t for-cify?
|
||||
prim-knowns knowns imports mutated)]))]
|
||||
prim-knowns knowns imports mutated simples)]))]
|
||||
[`(call-with-values ,generator ,receiver)
|
||||
(cond
|
||||
[(and (lambda? generator)
|
||||
|
|
@ -595,7 +619,7 @@
|
|||
(left-to-right/app (if for-cify? 'call-with-values '#%call-with-values)
|
||||
(list (schemify generator) (schemify receiver))
|
||||
#t for-cify?
|
||||
prim-knowns knowns imports mutated)])]
|
||||
prim-knowns knowns imports mutated simples)])]
|
||||
[`((letrec-values ,binds ,rator) ,rands ...)
|
||||
(schemify `(letrec-values ,binds (,rator . ,rands)))]
|
||||
[`(,rator ,exps ...)
|
||||
|
|
@ -693,7 +717,7 @@
|
|||
(left-to-right/app (car e)
|
||||
(cdr e)
|
||||
#t for-cify?
|
||||
prim-knowns knowns imports mutated))]
|
||||
prim-knowns knowns imports mutated simples))]
|
||||
[(and (not for-cify?)
|
||||
(known-field-accessor? k)
|
||||
(inline-field-access k s-rator im args))
|
||||
|
|
@ -707,14 +731,14 @@
|
|||
(left-to-right/app (known-procedure/has-unsafe-alternate k)
|
||||
args
|
||||
#t for-cify?
|
||||
prim-knowns knowns imports mutated)]
|
||||
prim-knowns knowns imports mutated simples)]
|
||||
[else
|
||||
(define plain-app? (or (known-procedure? k)
|
||||
(lambda? rator)))
|
||||
(left-to-right/app s-rator
|
||||
args
|
||||
plain-app? for-cify?
|
||||
prim-knowns knowns imports mutated)])))]
|
||||
prim-knowns knowns imports mutated simples)])))]
|
||||
[`,_
|
||||
(let ([u-v (unwrap v)])
|
||||
(cond
|
||||
|
|
@ -722,38 +746,46 @@
|
|||
v]
|
||||
[(eq? u-v 'call-with-values)
|
||||
'#%call-with-values]
|
||||
[(and (via-variable-mutated-state? (hash-ref mutated u-v #f))
|
||||
(hash-ref exports u-v #f))
|
||||
=> (lambda (ex) `(variable-ref ,(export-id ex)))]
|
||||
[(hash-ref imports u-v #f)
|
||||
=> (lambda (im)
|
||||
(define k (import-lookup im))
|
||||
(if (known-constant? k)
|
||||
;; Not boxed:
|
||||
(cond
|
||||
[(known-literal? k)
|
||||
;; We'd normally leave this to `optimize`, but
|
||||
;; need to handle it here before generating a
|
||||
;; reference to the renamed identifier
|
||||
(known-literal-expr k)]
|
||||
[(and (known-copy? k)
|
||||
(hash-ref prim-knowns (known-copy-id k) #f))
|
||||
;; Directly reference primitive
|
||||
(known-copy-id k)]
|
||||
[else
|
||||
(import-id im)])
|
||||
;; Will be boxed, but won't be undefined (because the
|
||||
;; module system won't link to an instance whose
|
||||
;; definitions didn't complete):
|
||||
`(variable-ref/no-check ,(import-id im))))]
|
||||
[(hash-ref knowns u-v #f)
|
||||
=> (lambda (k)
|
||||
(cond
|
||||
[(and (known-copy? k)
|
||||
(simple-mutated-state? (hash-ref mutated u-v #f)))
|
||||
(schemify (known-copy-id k))]
|
||||
[else v]))]
|
||||
[else v]))])))
|
||||
[else
|
||||
(define state (hash-ref mutated u-v #f))
|
||||
(cond
|
||||
[(and (via-variable-mutated-state? state)
|
||||
(hash-ref exports u-v #f))
|
||||
=> (lambda (ex) `(variable-ref ,(export-id ex)))]
|
||||
[(hash-ref imports u-v #f)
|
||||
=> (lambda (im)
|
||||
(define k (import-lookup im))
|
||||
(if (known-constant? k)
|
||||
;; Not boxed:
|
||||
(cond
|
||||
[(known-literal? k)
|
||||
;; We'd normally leave this to `optimize`, but
|
||||
;; need to handle it here before generating a
|
||||
;; reference to the renamed identifier
|
||||
(known-literal-expr k)]
|
||||
[(and (known-copy? k)
|
||||
(hash-ref prim-knowns (known-copy-id k) #f))
|
||||
;; Directly reference primitive
|
||||
(known-copy-id k)]
|
||||
[else
|
||||
(import-id im)])
|
||||
;; Will be boxed, but won't be undefined (because the
|
||||
;; module system won't link to an instance whose
|
||||
;; definitions didn't complete):
|
||||
`(variable-ref/no-check ,(import-id im))))]
|
||||
[(hash-ref knowns u-v #f)
|
||||
=> (lambda (k)
|
||||
(cond
|
||||
[(and (known-copy? k)
|
||||
(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))
|
||||
|
||||
(define (schemify-body l)
|
||||
|
|
|
|||
|
|
@ -11,46 +11,60 @@
|
|||
;; Check whether an expression is simple in the sense that its order
|
||||
;; of evaluation isn't detectable. This function receives both
|
||||
;; 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])
|
||||
(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
|
||||
[`(lambda . ,_) #t]
|
||||
[`(case-lambda . ,_) #t]
|
||||
[`(quote . ,_) #t]
|
||||
[`(#%variable-reference . ,_) #t]
|
||||
[`(let-values ([,_ ,rhss] ...) ,body)
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body))]
|
||||
(cached
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body)))]
|
||||
[`(let ([,_ ,rhss] ...) ,body)
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body))]
|
||||
(cached
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body)))]
|
||||
[`(letrec-values ([(,idss ...) ,rhss] ...) ,body)
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body))]
|
||||
(cached
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body)))]
|
||||
[`(letrec* ([,ids ,rhss] ...) ,body)
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body))]
|
||||
(cached
|
||||
(and (for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs))
|
||||
(simple? body)))]
|
||||
[`(begin ,es ...)
|
||||
#:guard (not pure?)
|
||||
(for/and ([e (in-list es)])
|
||||
(simple? e))]
|
||||
(cached
|
||||
(for/and ([e (in-list es)])
|
||||
(simple? e)))]
|
||||
[`(,proc . ,args)
|
||||
(let ([proc (unwrap proc)])
|
||||
(and (symbol? proc)
|
||||
(let ([v (or (hash-ref-either knowns imports proc)
|
||||
(hash-ref prim-knowns proc #f))])
|
||||
(and (if pure?
|
||||
(known-procedure/pure? v)
|
||||
(known-procedure/succeeds? v))
|
||||
(bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
|
||||
(simple-mutated-state? (hash-ref mutated proc #f))
|
||||
(for/and ([arg (in-list args)])
|
||||
(simple? arg))))]
|
||||
(cached
|
||||
(let ([proc (unwrap proc)])
|
||||
(and (symbol? proc)
|
||||
(let ([v (or (hash-ref-either knowns imports proc)
|
||||
(hash-ref prim-knowns proc #f))])
|
||||
(and (if pure?
|
||||
(known-procedure/pure? v)
|
||||
(known-procedure/succeeds? v))
|
||||
(bitwise-bit-set? (known-procedure-arity-mask v) (length args))))
|
||||
(simple-mutated-state? (hash-ref mutated proc #f))
|
||||
(for/and ([arg (in-list args)])
|
||||
(simple? arg)))))]
|
||||
[`,_
|
||||
(let ([e (unwrap e)])
|
||||
(or (and (symbol? e)
|
||||
|
|
|
|||
|
|
@ -150,7 +150,7 @@
|
|||
[`,_ #f]))
|
||||
|
||||
(define (struct-convert-local form #:letrec? [letrec? #f]
|
||||
prim-knowns knowns imports mutated
|
||||
prim-knowns knowns imports mutated simples
|
||||
schemify
|
||||
#:unsafe-mode? unsafe-mode?)
|
||||
(match form
|
||||
|
|
@ -164,7 +164,7 @@
|
|||
(match new-seq
|
||||
[`(begin . ,new-seq)
|
||||
(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))
|
||||
(cond
|
||||
[letrec?
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@
|
|||
;; 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
|
||||
;; 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
|
||||
[`(list (cons ,props ,vals) ...)
|
||||
(for/and ([prop (in-list props)]
|
||||
|
|
@ -96,7 +96,7 @@
|
|||
(and (symbol? u-prop)
|
||||
(or (known-struct-type-property/immediate-guard?
|
||||
(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]
|
||||
[`'() #t]
|
||||
[`,_ #f]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user