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

schemify: optimize with-continuation-marks

Browse Source 
Prune some `with-continuation-marks` forms that aren't observable
(because the body is simple enough that it won't inspect marks). More
significantly, specialize `with-continuation-marks` forms to indicate
when the current frame is known to have no marks and to indicate
when tthe key expression is known to produce a non-impersonator.
This commit is contained in:
Matthew Flatt 2019-09-20 10:38:41 -06:00
parent 7ae4943a57
commit 7d725ab48b
16 changed files with 221 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/src/cs/primitive/kernel.ss
View File

@ -19,7 +19,7 @@
[acos (known-procedure/folding 2)] [acos (known-procedure/folding 2)]
[add1 (known-procedure/folding 2)] [add1 (known-procedure/folding 2)]
[alarm-evt (known-procedure/no-prompt 2)] [alarm-evt (known-procedure/no-prompt 2)]
[always-evt (known-constant)] [always-evt (known-authentic)]
[andmap (known-procedure -4)] [andmap (known-procedure -4)]
[angle (known-procedure/folding 2)] [angle (known-procedure/folding 2)]
[append (known-procedure/no-prompt -1)] [append (known-procedure/no-prompt -1)]
@ -552,7 +552,7 @@
[mpair? (known-procedure/pure/folding 2)] [mpair? (known-procedure/pure/folding 2)]
[nack-guard-evt (known-procedure/no-prompt 2)] [nack-guard-evt (known-procedure/no-prompt 2)]
[negative? (known-procedure/folding 2)] [negative? (known-procedure/folding 2)]
[never-evt (known-constant)] [never-evt (known-authentic)]
[newline (known-procedure 3)] [newline (known-procedure 3)]
[not (known-procedure/pure/folding 2)] [not (known-procedure/pure/folding 2)]
[null (known-literal '())] [null (known-literal '())]

6
racket/src/cs/primitive/paramz.ss
View File

@ -1,11 +1,11 @@
(define-primitive-table paramz-table (define-primitive-table paramz-table
[break-enabled-key (known-constant)] [break-enabled-key (known-authentic)]
[cache-configuration (known-procedure 4)] [cache-configuration (known-procedure 4)]
[check-for-break (known-procedure 1)] [check-for-break (known-procedure 1)]
[exception-handler-key (known-constant)] [exception-handler-key (known-authentic)]
[extend-parameterization (known-procedure -2)] [extend-parameterization (known-procedure -2)]
[parameterization-key (known-constant)] [parameterization-key (known-authentic)]
[reparameterize (known-procedure 2)] [reparameterize (known-procedure 2)]
[security-guard-check-file (known-procedure 8)] [security-guard-check-file (known-procedure 8)]
[security-guard-check-file-link (known-procedure 8)] [security-guard-check-file-link (known-procedure 8)]

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

@ -29,6 +29,7 @@
unsafe-call-with-composable-continuation/no-wind unsafe-call-with-composable-continuation/no-wind
with-continuation-mark with-continuation-mark
with-continuation-mark* ; not exported to Racket
(rename [call-with-immediate-continuation-mark/inline (rename [call-with-immediate-continuation-mark/inline
call-with-immediate-continuation-mark] call-with-immediate-continuation-mark]
[call-with-immediate-continuation-mark [call-with-immediate-continuation-mark

42
racket/src/cs/rumble/control.ss
View File

@ -940,6 +940,48 @@
(lambda () (lambda ()
body)))))])) body)))))]))
;; Specializations of `with-continuation-mark*` as determined by a mode:
(define-syntax with-continuation-mark*
(lambda (stx)
(syntax-case stx ()
[(_ mode key val body)
(case (syntax->datum #'mode)
[(general)
#'(with-continuation-mark key val body)]
[(push)
;; Assume no mark in place for this frame
#'(let* ([k key]
[v val])
(call-setting-continuation-attachment
(if (impersonator? k)
(mark-frame-update empty-mark-frame k v)
(cons k v))
(lambda ()
body)))]
[(authentic)
;; Assume `key` produces an authentic value
#'(let* ([k key]
[v val])
(call-consuming-continuation-attachment
empty-mark-frame
(lambda (a)
(call-setting-continuation-attachment
(if a
(mark-frame-update a k v)
(cons k v))
(lambda ()
body)))))]
[(push-authentic)
;; Assume no mark in place, and `key` produces an authentic value
#'(let* ([k key]
[v val])
(call-setting-continuation-attachment
(cons k v)
(lambda ()
body)))]
[else
(#%error 'with-continuation-mark* "unrecognized mode: ~s" #'mode)])])))
;; Return a continuation that expects a thunk to resume. That way, we ;; Return a continuation that expects a thunk to resume. That way, we
;; can can an `(end-uninterrupted)` and check for breaks in the ;; can can an `(end-uninterrupted)` and check for breaks in the
;; destination continuation ;; destination continuation

1
racket/src/expander/compile/built-in-symbol.rkt
View File

@ -57,6 +57,7 @@
letrec* letrec*
define define
$value $value
with-continuation-mark*
pariah pariah
variable-set! variable-set!
variable-ref variable-ref

36
racket/src/schemify/authentic.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang racket/base
(require "wrap.rkt"
"match.rkt"
"known.rkt"
"import.rkt"
"mutated-state.rkt")
(provide authentic-valued?)
;; Check whether pre-schemifed `v` is known to produce a non-impersonator
(define (authentic-valued? v knowns prim-knowns imports mutated)
(let authentic-valued? ([v v])
(match v
[`(quote ,v)
(not (impersonator? v))]
[`,_
(define u-v (unwrap v))
(cond
[(symbol? u-v)
(cond
[(not (simple-mutated-state? (hash-ref mutated u-v #f)))
#f]
[(or (hash-ref prim-knowns u-v #f)
(hash-ref-either knowns imports u-v))
=> (lambda (k)
(or (known-authentic? k)
(known-procedure? k)
(and (known-literal? k)
(not (impersonator? (known-literal-value k))))
(and (known-copy? k)
(authentic-valued? (known-copy-id k)))))]
[else #f])]
[else
;; Any literal allows as unquoted is authentic
(not (pair? u-v))])])))

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

@ -243,7 +243,7 @@
(compile-expr tst env stack-depth stk-i #f) (compile-expr tst env stack-depth stk-i #f)
(add-clears new-then then-stk-i all-clear) (add-clears new-then then-stk-i all-clear)
(add-clears new-else else-stk-i all-clear))] (add-clears new-else else-stk-i all-clear))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
(define new-body (compile-expr body env stack-depth stk-i tail?)) (define new-body (compile-expr body env stack-depth stk-i tail?))
(define new-val (compile-expr val env stack-depth stk-i #f)) (define new-val (compile-expr val env stack-depth stk-i #f))
(vector 'wcm (vector 'wcm
@ -841,7 +841,8 @@
(letrec ([ok 'ok]) (letrec ([ok 'ok])
(set! other (call-with-values (lambda () (values 71 (begin0 88 ok))) (set! other (call-with-values (lambda () (values 71 (begin0 88 ok)))
(lambda (v q) (list q v)))) (lambda (v q) (list q v))))
(with-continuation-mark (with-continuation-mark*
general
'x 'cm/x 'x 'cm/x
(list (if s s #f) x ok other (list (if s s #f) x ok other
(f 'vec) (g 'also-vec 'more) (f 'vec) (g 'also-vec 'more)

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

@ -286,7 +286,7 @@
(values (reannotate v `(if ,new-tst ,new-thn ,new-els)) (values (reannotate v `(if ,new-tst ,new-thn ,new-els))
new-free/els new-free/els
new-lifts/els)] new-lifts/els)]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
(define sub-convert-mode (convert-mode-non-tail convert-mode)) (define sub-convert-mode (convert-mode-non-tail convert-mode))
(define-values (new-key new-free/key new-lifts/key) (define-values (new-key new-free/key new-lifts/key)
(jitify-expr key env mutables free lifts sub-convert-mode #f in-name)) (jitify-expr key env mutables free lifts sub-convert-mode #f in-name))
@ -294,7 +294,7 @@
(jitify-expr val env mutables new-free/key new-lifts/key sub-convert-mode #f in-name)) (jitify-expr val env mutables new-free/key new-lifts/key sub-convert-mode #f in-name))
(define-values (new-body new-free/body new-lifts/body) (define-values (new-body new-free/body new-lifts/body)
(jitify-expr body env mutables new-free/val new-lifts/val convert-mode name in-name)) (jitify-expr body env mutables new-free/val new-lifts/val convert-mode name in-name))
(values (reannotate v `(with-continuation-mark ,new-key ,new-val ,new-body)) (values (reannotate v `(with-continuation-mark* ,mode ,new-key ,new-val ,new-body))
new-free/body new-free/body
new-lifts/body)] new-lifts/body)]
[`(quote ,_) (values v free lifts)] [`(quote ,_) (values v free lifts)]
@ -651,7 +651,7 @@
(find-mutable env tst (find-mutable env tst
(find-mutable env thn (find-mutable env thn
(find-mutable env els accum)))] (find-mutable env els accum)))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
(find-mutable env key (find-mutable env key
(find-mutable env val (find-mutable env val
(find-mutable env body accum)))] (find-mutable env body accum)))]
@ -797,7 +797,7 @@
(record-sizes! tst sizes) (record-sizes! tst sizes)
(record-sizes! thn sizes) (record-sizes! thn sizes)
(record-sizes! els sizes))] (record-sizes! els sizes))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
(+ 1 (+ 1
(record-sizes! key sizes) (record-sizes! key sizes)
(record-sizes! val sizes) (record-sizes! val sizes)

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

@ -5,6 +5,7 @@
(provide known-constant known-constant? (provide known-constant known-constant?
known-consistent known-consistent? known-consistent known-consistent?
known-authentic known-authentic?
known-copy? known-copy known-copy-id known-copy? known-copy known-copy-id
known-literal known-literal? known-literal-value known-literal known-literal? known-literal-value
known-procedure known-procedure? known-procedure-arity-mask known-procedure known-procedure? known-procedure-arity-mask
@ -46,6 +47,9 @@
;; being a predicate for a structure type ;; being a predicate for a structure type
(struct known-consistent () #:prefab #:omit-define-syntaxes #:super struct:known-constant) (struct known-consistent () #:prefab #:omit-define-syntaxes #:super struct:known-constant)
;; the value at run time is never an impersonator
(struct known-authentic () #:prefab #:omit-define-syntaxes #:super struct:known-constant)
;; copy propagation --- use for local bindings or copies of primitives, only ;; copy propagation --- use for local bindings or copies of primitives, only
(struct known-copy (id) #:prefab #:omit-define-syntaxes #:super struct:known-constant) (struct known-copy (id) #:prefab #:omit-define-syntaxes #:super struct:known-constant)
@ -77,7 +81,7 @@
;; procedure that never raises an exception or otherwise captures/escapes the calling context ;; procedure that never raises an exception or otherwise captures/escapes the calling context
(struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/no-prompt) (struct known-procedure/succeeds () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/no-prompt)
;; procedure that accepts any arguments and is functional so that it can be reordered ;; procedure that accepts any arguments, returns a single value, and is functional so that it can be reordered
(struct known-procedure/pure () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds) (struct known-procedure/pure () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/succeeds)
;; pure and folding: ;; pure and folding:

20
racket/src/schemify/lift.rkt
View File

@ -102,7 +102,7 @@
(lift-in-expr? v))] (lift-in-expr? v))]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
(or (lift-in-expr? tst) (lift-in-expr? thn) (lift-in-expr? els))] (or (lift-in-expr? tst) (lift-in-expr? thn) (lift-in-expr? els))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,_ ,key ,val ,body)
(or (lift-in-expr? key) (lift-in-expr? val) (lift-in-expr? body))] (or (lift-in-expr? key) (lift-in-expr? val) (lift-in-expr? body))]
[`(quote ,_) #f] [`(quote ,_) #f]
[`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")] [`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")]
@ -143,7 +143,7 @@
[`(quote . ,_) #f] [`(quote . ,_) #f]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
(or (lift? tst) (lift? thn) (lift? els))] (or (lift? tst) (lift? thn) (lift? els))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,_ ,key ,val ,body)
(or (lift? key) (lift? val) (lift? body))] (or (lift? key) (lift? val) (lift? body))]
[`(set! ,_ ,rhs) (lift? rhs)] [`(set! ,_ ,rhs) (lift? rhs)]
[`(#%variable-reference) #f] [`(#%variable-reference) #f]
@ -229,10 +229,12 @@
(reannotate v `(if ,(lift-in-expr tst) (reannotate v `(if ,(lift-in-expr tst)
,(lift-in-expr thn) ,(lift-in-expr thn)
,(lift-in-expr els)))] ,(lift-in-expr els)))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
(reannotate v `(with-continuation-mark ,(lift-in-expr key) (reannotate v `(with-continuation-mark*
,(lift-in-expr val) ,mode
,(lift-in-expr body)))] ,(lift-in-expr key)
,(lift-in-expr val)
,(lift-in-expr body)))]
[`(quote ,_) v] [`(quote ,_) v]
[`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")] [`(#%variable-reference . ,_) (error 'internal-error "unexpected variable reference")]
[`(set! ,id ,rhs) [`(set! ,id ,rhs)
@ -310,7 +312,7 @@
[frees+binds (compute-lifts! thn frees+binds lifts locals)] [frees+binds (compute-lifts! thn frees+binds lifts locals)]
[frees+binds (compute-lifts! els frees+binds lifts locals)]) [frees+binds (compute-lifts! els frees+binds lifts locals)])
frees+binds)] frees+binds)]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,_ ,key ,val ,body)
(let* ([frees+binds (compute-lifts! key frees+binds lifts locals)] (let* ([frees+binds (compute-lifts! key frees+binds lifts locals)]
[frees+binds (compute-lifts! val frees+binds lifts locals)] [frees+binds (compute-lifts! val frees+binds lifts locals)]
[frees+binds (compute-lifts! body frees+binds lifts locals)]) [frees+binds (compute-lifts! body frees+binds lifts locals)])
@ -519,8 +521,8 @@
[`(quote . ,_) v] [`(quote . ,_) v]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
(reannotate v `(if ,(convert tst) ,(convert thn) ,(convert els)))] (reannotate v `(if ,(convert tst) ,(convert thn) ,(convert els)))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
(reannotate v `(with-continuation-mark ,(convert key) ,(convert val) ,(convert body)))] (reannotate v `(with-continuation-mark* ,mode ,(convert key) ,(convert val) ,(convert body)))]
[`(set! ,id ,rhs) [`(set! ,id ,rhs)
(define info (and (hash-ref lifts (unwrap id) #f))) (define info (and (hash-ref lifts (unwrap id) #f)))
(cond (cond

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

@ -21,6 +21,8 @@
(if (literal? t) (if (literal? t)
(if (unwrap t) e1 e2) (if (unwrap t) e1 e2)
v)] v)]
[`(begin (quote ,_) ,e . ,es) ; avoid `begin` that looks like it provides a name
(optimize (reannotate v `(begin ,e . ,es)) prim-knowns primitives knowns imports mutated)]
[`(not ,t) [`(not ,t)
(if (literal? t) (if (literal? t)
`,(not (unwrap t)) `,(not (unwrap t))
@ -76,8 +78,8 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Recursive optimization --- useful when not fused with schemify, ;; Recursive optimization on pre-schemified --- useful when not fused with
;; such as for an initial optimization pass on a definition of a ;; schemify, such as for an initial optimization pass on a definition of a
;; function that can be inlined (where converting away ;; function that can be inlined (where converting away
;; `variable-reference-from-unsafe?` is particularly important) ;; `variable-reference-from-unsafe?` is particularly important)

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

@ -21,7 +21,9 @@
"letrec.rkt" "letrec.rkt"
"infer-name.rkt" "infer-name.rkt"
"ptr-ref-set.rkt" "ptr-ref-set.rkt"
"literal.rkt") "literal.rkt"
"authentic.rkt"
"single-valued.rkt")
(provide schemify-linklet (provide schemify-linklet
schemify-body) schemify-body)
@ -428,8 +430,9 @@
;; effectively canceled with a mapping in `knowns`. ;; effectively canceled with a mapping in `knowns`.
(define (schemify v prim-knowns primitives knowns mutated imports exports simples allow-set!-undefined? add-import! (define (schemify v prim-knowns primitives 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]) ;; `wcm-state` is one of: 'tail (= unknown), 'fresh (= no marks), or 'marked (= some marks)
(define (schemify v) (let schemify/knowns ([knowns knowns] [inline-fuel init-inline-fuel] [wcm-state 'tail] [v v])
(define (schemify v wcm-state)
(define s-v (define s-v
(reannotate (reannotate
v v
@ -437,13 +440,13 @@
[`(lambda ,formals ,body ...) [`(lambda ,formals ,body ...)
(infer-procedure-name (infer-procedure-name
v v
`(lambda ,formals ,@(schemify-body body)))] `(lambda ,formals ,@(schemify-body body 'tail)))]
[`(case-lambda [,formalss ,bodys ...] ...) [`(case-lambda [,formalss ,bodys ...] ...)
(infer-procedure-name (infer-procedure-name
v v
`(case-lambda ,@(for/list ([formals (in-list formalss)] `(case-lambda ,@(for/list ([formals (in-list formalss)]
[body (in-list bodys)]) [body (in-list bodys)])
`[,formals ,@(schemify-body body)])))] `[,formals ,@(schemify-body body 'tail)])))]
[`(define-values (,struct:s ,make-s ,s? ,acc/muts ...) [`(define-values (,struct:s ,make-s ,s? ,acc/muts ...)
(let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk)) (let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk))
(values ,struct:2 (values ,struct:2
@ -453,20 +456,20 @@
#:guard (not (or for-jitify? for-cify?)) #:guard (not (or for-jitify? for-cify?))
(define new-seq (define new-seq
(struct-convert v prim-knowns knowns imports mutated (struct-convert v prim-knowns knowns imports mutated
(lambda (v knowns) (schemify/knowns knowns inline-fuel v)) no-prompt?)) (lambda (v knowns) (schemify/knowns knowns inline-fuel 'fresh v)) no-prompt?))
(or new-seq (or new-seq
(match v (match v
[`(,_ ,ids ,rhs) [`(,_ ,ids ,rhs)
`(define-values ,ids ,(schemify rhs))]))] `(define-values ,ids ,(schemify rhs 'fresh))]))]
[`(define-values (,id) ,rhs) [`(define-values (,id) ,rhs)
`(define ,id ,(schemify rhs))] `(define ,id ,(schemify rhs 'fresh))]
[`(define-values ,ids ,rhs) [`(define-values ,ids ,rhs)
`(define-values ,ids ,(schemify rhs))] `(define-values ,ids ,(schemify rhs 'fresh))]
[`(quote ,_) v] [`(quote ,_) v]
[`(let-values () ,body) [`(let-values () ,body)
(schemify body)] (schemify body wcm-state)]
[`(let-values () ,bodys ...) [`(let-values () ,bodys ...)
(schemify `(begin . ,bodys))] (schemify `(begin . ,bodys) wcm-state)]
[`(let-values ([(,ids) ,rhss] ...) ,bodys ...) [`(let-values ([(,ids) ,rhss] ...) ,bodys ...)
(define new-knowns (define new-knowns
(for/fold ([knowns knowns]) ([id (in-list ids)] (for/fold ([knowns knowns]) ([id (in-list ids)]
@ -487,29 +490,29 @@
(for/list ([id (in-list ids)] (for/list ([id (in-list ids)]
[rhs (in-list rhss)] [rhs (in-list rhss)]
#:unless (merely-a-copy? id)) #:unless (merely-a-copy? id))
(schemify rhs)) (schemify rhs 'fresh))
(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 wcm-state body))
prim-knowns knowns imports mutated simples)] 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 'fresh) ,@(schemify-body bodys wcm-state))]
[`(let-values ([,idss ,rhss] ...) ,bodys ...) [`(let-values ([,idss ,rhss] ...) ,bodys ...)
(or (struct-convert-local v prim-knowns knowns imports mutated simples (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 'fresh v))
#:unsafe-mode? unsafe-mode?) #:unsafe-mode? unsafe-mode?)
(left-to-right/let-values idss (left-to-right/let-values idss
(for/list ([rhs (in-list rhss)]) (for/list ([rhs (in-list rhss)])
(schemify rhs)) (schemify rhs 'fresh))
(schemify-body bodys) (schemify-body bodys wcm-state)
mutated mutated
for-cify?))] for-cify?))]
[`(letrec-values () ,bodys ...) [`(letrec-values () ,bodys ...)
(schemify `(begin . ,bodys))] (schemify `(begin . ,bodys) wcm-state)]
[`(letrec-values ([() (values)]) ,bodys ...) [`(letrec-values ([() (values)]) ,bodys ...)
(schemify `(begin . ,bodys))] (schemify `(begin . ,bodys) wcm-state)]
[`(letrec-values ([(,id) (values ,rhs)]) ,bodys ...) [`(letrec-values ([(,id) (values ,rhs)]) ,bodys ...)
;; special case of splitable values: ;; special case of splitable values:
(schemify `(letrec-values ([(,id) ,rhs]) . ,bodys))] (schemify `(letrec-values ([(,id) ,rhs]) . ,bodys) wcm-state)]
[`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...) [`(letrec-values ([(,ids) ,rhss] ...) ,bodys ...)
(define-values (rhs-knowns body-knowns) (define-values (rhs-knowns body-knowns)
(for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)] (for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)]
@ -525,18 +528,19 @@
ids mutated for-cify? ids mutated for-cify?
`(letrec* ,(for/list ([id (in-list ids)] `(letrec* ,(for/list ([id (in-list ids)]
[rhs (in-list rhss)]) [rhs (in-list rhss)])
`[,id ,(schemify/knowns rhs-knowns inline-fuel rhs)]) `[,id ,(schemify/knowns rhs-knowns inline-fuel 'fresh rhs)])
,@(for/list ([body (in-list bodys)]) ,@(for/list ([body (in-list bodys)])
(schemify/knowns body-knowns inline-fuel body))))] (schemify/knowns body-knowns inline-fuel wcm-state body))))]
[`(letrec-values ([,idss ,rhss] ...) ,bodys ...) [`(letrec-values ([,idss ,rhss] ...) ,bodys ...)
(cond (cond
[(struct-convert-local v #:letrec? #t prim-knowns knowns imports mutated simples [(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 'fresh v))
#:unsafe-mode? unsafe-mode?) #:unsafe-mode? unsafe-mode?)
=> (lambda (form) form)] => (lambda (form) form)]
[(letrec-splitable-values-binding? idss rhss) [(letrec-splitable-values-binding? idss rhss)
(schemify (schemify
(letrec-split-values-binding idss rhss bodys))] (letrec-split-values-binding idss rhss bodys)
wcm-state)]
[else [else
;; Convert ;; Convert
;; (letrec*-values ([(id ...) rhs] ...) ....) ;; (letrec*-values ([(id ...) rhs] ...) ....)
@ -551,7 +555,7 @@
append append
(for/list ([ids (in-wrap-list idss)] (for/list ([ids (in-wrap-list idss)]
[rhs (in-list rhss)]) [rhs (in-list rhss)])
(let ([rhs (schemify rhs)]) (let ([rhs (schemify rhs 'fresh)])
(cond (cond
[(null? ids) [(null? ids)
`([,(gensym "lr") `([,(gensym "lr")
@ -564,21 +568,41 @@
,@(for/list ([id (in-list ids)] ,@(for/list ([id (in-list ids)]
[pos (in-naturals)]) [pos (in-naturals)])
`[,id (unsafe-vector*-ref ,lr ,pos)]))])))) `[,id (unsafe-vector*-ref ,lr ,pos)]))]))))
,@(schemify-body bodys)))])] ,@(schemify-body bodys wcm-state)))])]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
`(if ,(schemify tst) ,(schemify thn) ,(schemify els))] `(if ,(schemify tst 'fresh) ,(schemify thn wcm-state) ,(schemify els wcm-state))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark ,key ,val ,body)
`(with-continuation-mark ,(schemify key) ,(schemify val) ,(schemify body))] (define s-key (schemify key 'fresh))
(define s-val (schemify val 'fresh))
(define s-body (schemify body 'marked))
(define authentic-key?
(authentic-valued? key knowns prim-knowns imports mutated))
(cond
[(and authentic-key?
(simple? s-body prim-knowns knowns imports mutated simples))
`(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated)
,(ensure-single-valued s-val knowns prim-knowns imports mutated)
,s-body)]
[for-cify?
`(with-continuation-mark ,s-key ,s-val ,s-body)]
[else
(define mode
(case wcm-state
[(fresh) (if authentic-key? 'push-authentic 'push)]
[else (if authentic-key? 'authentic 'general)]))
`(with-continuation-mark* ,mode ,s-key ,s-val ,s-body)])]
[`(begin ,exp) [`(begin ,exp)
(schemify exp)] (schemify exp wcm-state)]
[`(begin ,exps ...) [`(begin ,exps ...)
`(begin . ,(schemify-body exps))] `(begin . ,(schemify-body exps wcm-state))]
[`(begin0 ,exps ...) [`(begin0 ,exp)
`(begin0 . ,(schemify-body exps))] (schemify exp wcm-state)]
[`(begin0 ,exp ,exps ...)
`(begin0 ,(schemify exp 'fresh) . ,(schemify-body exps 'fresh))]
[`(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))
(define new-rhs (schemify rhs)) (define new-rhs (schemify rhs 'fresh))
(define state (hash-ref mutated int-id #f)) (define state (hash-ref mutated int-id #f))
(cond (cond
[ex [ex
@ -612,7 +636,7 @@
[(known-constant? (import-lookup im)) #t] [(known-constant? (import-lookup im)) #t]
[else [else
;; Not statically known ;; Not statically known
`(variable-reference-constant? ,(schemify `(#%variable-reference ,id)))])])] `(variable-reference-constant? ,(schemify `(#%variable-reference ,id) 'fresh))])])]
[`(variable-reference-from-unsafe? (#%variable-reference)) [`(variable-reference-from-unsafe? (#%variable-reference))
unsafe-mode?] unsafe-mode?]
[`(#%variable-reference) [`(#%variable-reference)
@ -634,8 +658,8 @@
[(hash-ref prim-knowns u #f) u] ; assuming that `mutable` and `constant` are not primitives [(hash-ref prim-knowns u #f) u] ; assuming that `mutable` and `constant` are not primitives
[else 'constant])))] [else 'constant])))]
[`(equal? ,exp1 ,exp2) [`(equal? ,exp1 ,exp2)
(let ([exp1 (schemify exp1)] (let ([exp1 (schemify exp1 'fresh)]
[exp2 (schemify exp2)]) [exp2 (schemify exp2 'fresh)])
(cond (cond
[(or (equal-implies-eq? exp1) (equal-implies-eq? exp2)) [(or (equal-implies-eq? exp1) (equal-implies-eq? exp2))
`(eq? ,exp1 ,exp2)] `(eq? ,exp1 ,exp2)]
@ -650,17 +674,17 @@
(cond (cond
[(and (lambda? generator) [(and (lambda? generator)
(lambda? receiver)) (lambda? receiver))
`(call-with-values ,(schemify generator) ,(schemify receiver))] `(call-with-values ,(schemify generator 'fresh) ,(schemify receiver 'fresh))]
[else [else
(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 'fresh) (schemify receiver 'fresh))
#t for-cify? #t for-cify?
prim-knowns knowns imports mutated simples)])] prim-knowns knowns imports mutated simples)])]
[`(single-flonum-available?) [`(single-flonum-available?)
;; Fold to a boolean to allow earlier simplification ;; Fold to a boolean to allow earlier simplification
for-cify?] for-cify?]
[`((letrec-values ,binds ,rator) ,rands ...) [`((letrec-values ,binds ,rator) ,rands ...)
(schemify `(letrec-values ,binds (,rator . ,rands)))] (schemify `(letrec-values ,binds (,rator . ,rands)) wcm-state)]
[`(,rator ,exps ...) [`(,rator ,exps ...)
(define (left-left-lambda-convert rator inline-fuel) (define (left-left-lambda-convert rator inline-fuel)
(match rator (match rator
@ -672,6 +696,7 @@
(and (wrap-null? args) (and (wrap-null? args)
(schemify/knowns knowns (schemify/knowns knowns
inline-fuel inline-fuel
wcm-state
`(let-values ,(reverse binds) . ,bodys)))] `(let-values ,(reverse binds) . ,bodys)))]
[(null? args) #f] [(null? args) #f]
[(not (wrap-pair? formal-args)) [(not (wrap-pair? formal-args))
@ -719,7 +744,7 @@
(cond (cond
[type-id [type-id
(define tmp (maybe-tmp (car args) 'v)) (define tmp (maybe-tmp (car args) 'v))
(define sel `(if (unsafe-struct? ,tmp ,(schemify type-id)) (define sel `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
(unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k)) (unsafe-struct*-ref ,tmp ,(known-field-accessor-pos k))
(,s-rator ,tmp))) (,s-rator ,tmp)))
(wrap-tmp tmp (car args) (wrap-tmp tmp (car args)
@ -735,7 +760,7 @@
[type-id [type-id
(define tmp (maybe-tmp (car args) 'v)) (define tmp (maybe-tmp (car args) 'v))
(define tmp-rhs (maybe-tmp (cadr args) 'rhs)) (define tmp-rhs (maybe-tmp (cadr args) 'rhs))
(define mut `(if (unsafe-struct? ,tmp ,(schemify type-id)) (define mut `(if (unsafe-struct? ,tmp ,(schemify type-id 'fresh))
(unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs) (unsafe-struct*-set! ,tmp ,(known-field-mutator-pos k) ,tmp-rhs)
(,s-rator ,tmp ,tmp-rhs))) (,s-rator ,tmp ,tmp-rhs)))
(wrap-tmp tmp (car args) (wrap-tmp tmp (car args)
@ -745,8 +770,8 @@
(or (left-left-lambda-convert rator inline-fuel) (or (left-left-lambda-convert rator inline-fuel)
(and (positive? inline-fuel) (and (positive? inline-fuel)
(inline-rator)) (inline-rator))
(let ([s-rator (schemify rator)] (let ([s-rator (schemify rator 'fresh)]
[args (schemify-body exps)] [args (schemify-body exps 'fresh)]
[u-rator (unwrap rator)]) [u-rator (unwrap rator)])
(define-values (k im) (find-known+import u-rator prim-knowns knowns imports mutated)) (define-values (k im) (find-known+import u-rator prim-knowns knowns imports mutated))
(cond (cond
@ -820,7 +845,7 @@
(cond (cond
[(and (known-copy? k) [(and (known-copy? k)
(simple-mutated-state? (hash-ref mutated u-v #f))) (simple-mutated-state? (hash-ref mutated u-v #f)))
(schemify (known-copy-id k))] (schemify (known-copy-id k) wcm-state)]
[else v]))] [else v]))]
[(and (too-early-mutated-state? state) [(and (too-early-mutated-state? state)
(not for-cify?)) (not for-cify?))
@ -830,8 +855,13 @@
[else v])]))]))) [else v])]))])))
(optimize s-v prim-knowns primitives knowns imports mutated)) (optimize s-v prim-knowns primitives knowns imports mutated))
(define (schemify-body l) (define (schemify-body l wcm-state)
(for/list ([e (in-list l)]) (cond
(schemify e))) [(null? l) null]
[(null? (cdr l))
(list (schemify (car l) wcm-state))]
[else
(cons (schemify (car l) 'fresh)
(schemify-body (cdr l) wcm-state))]))
(schemify v))) (schemify v 'fresh)))

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

@ -64,8 +64,8 @@
,@(convert-body bodys))] ,@(convert-body bodys))]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
`(if ,(convert tst) ,(convert thn) ,(convert els))] `(if ,(convert tst) ,(convert thn) ,(convert els))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
`(with-continuation-mark ,(convert key) ,(convert val) ,(convert body))] `(with-continuation-mark* ,mode ,(convert key) ,(convert val) ,(convert body))]
[`(begin ,exps ...) [`(begin ,exps ...)
`(begin . ,(convert-body exps))] `(begin . ,(convert-body exps))]
[`(begin0 ,exps ...) [`(begin0 ,exps ...)
@ -120,7 +120,7 @@
(or (convert-any? tst) (or (convert-any? tst)
(convert-any? thn) (convert-any? thn)
(convert-any? els))] (convert-any? els))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,_ ,key ,val ,body)
(or (convert-any? key) (or (convert-any? key)
(convert-any? val) (convert-any? val)
(convert-any? body))] (convert-any? body))]

25
racket/src/schemify/single-valued.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(require "match.rkt"
"wrap.rkt"
"known.rkt"
"import.rkt"
"mutated-state.rkt")
(provide ensure-single-valued)
(define (ensure-single-valued v knowns prim-knowns imports mutated)
(match v
[`(quote ,_) v]
[`(lambda . ,_) v]
[`(case-lambda . ,_) v]
[`(,proc-or-form . ,_)
(define u (unwrap proc-or-form))
(cond
[(and (symbol? u)
(simple-mutated-state? (hash-ref mutated u #f))
(let ([k (or (hash-ref prim-knowns u #f)
(hash-ref-either knowns imports u))])
(known-procedure/pure? k)))
v]
[else `($value ,v)])]
[`,_ v]))

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

@ -32,7 +32,7 @@
(body-leftover-size (cons rhss body) (sub1 size))] (body-leftover-size (cons rhss body) (sub1 size))]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
(leftover-size els (leftover-size thn (leftover-size tst (sub1 size))))] (leftover-size els (leftover-size thn (leftover-size tst (sub1 size))))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,_ ,key ,val ,body)
(leftover-size body (leftover-size val (leftover-size key (sub1 size))))] (leftover-size body (leftover-size val (leftover-size key (sub1 size))))]
[`(begin0 . ,body) [`(begin0 . ,body)
(body-leftover-size body (sub1 size))] (body-leftover-size body (sub1 size))]

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

@ -32,8 +32,8 @@
`(begin . ,(xify-body body env))] `(begin . ,(xify-body body env))]
[`(if ,tst ,thn ,els) [`(if ,tst ,thn ,els)
`(if ,(xify tst env) ,(xify thn env) ,(xify els env))] `(if ,(xify tst env) ,(xify thn env) ,(xify els env))]
[`(with-continuation-mark ,key ,val ,body) [`(with-continuation-mark* ,mode ,key ,val ,body)
`(with-continuation-mark ,(xify key env) ,(xify val env) ,(xify body env))] `(with-continuation-mark* ,mode ,(xify key env) ,(xify val env) ,(xify body env))]
[`(set! ,id ,rhs) [`(set! ,id ,rhs)
`(set! ,(xify id env) ,(xify rhs env))] `(set! ,(xify id env) ,(xify rhs env))]
;; Catch-all for other forms, which we can treat like applications ;; Catch-all for other forms, which we can treat like applications