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

cs & schemify: with-continuation-mark optimization

Browse Source 
Remove a `with-continuation-mark` that is redundant because its both
is another `with-continuation-mark` with the same key. That's useful
for reducing a pattern that appears after some `if`-removing
optimizations on code with errortrace-generated annotations.
This commit is contained in:
Matthew Flatt 2021-01-31 12:37:52 -07:00
parent fd642d2715
commit f968945e26
9 changed files with 399 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -14,7 +14,7 @@
;; In the Racket source repo, this version should change only when
;; "racket_version.h" changes:
(define version "8.0.0.4")
(define version "8.0.0.5")
(define deps `("racket-lib"
["racket" #:version ,version]))

4
racket/src/bc/src/startup.inc
View File

@ -20081,7 +20081,11 @@ static const char *startup_source =
"(if(unsafe-fx< index_0 25)"
"(let-values()"
"(let-values(((wrt-dir_0)"
"(let-values(((or-part_0)"
"(current-load-relative-directory)))"
"(if or-part_0"
" or-part_0"
"(current-directory)))))"
"(let-values(((rel-elems_0)"
"(reverse$1"
"(let-values(((lst_0)"

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

@ -586,7 +586,7 @@
1/srcloc->string
1/error-print-source-location)
(set-ffi-get-lib-and-obj! ffi-get-lib ffi-get-obj ffi-unload-lib ptr->address)
(set-make-async-callback-poll-wakeup! unsafe-make-signal-received)
(set-make-async-callback-poll-wakeup! 1/unsafe-make-signal-received)
(set-get-machine-info! get-machine-info)
(set-processor-count! (1/processor-count))
(install-future-logging-procs! logging-future-events? log-future-event)

13
racket/src/cs/schemified/io.scm
View File

@ -328,7 +328,7 @@
unsafe-file-descriptor->semaphore)
(1/unsafe-make-security-guard-at-root
unsafe-make-security-guard-at-root)
(unsafe-make-signal-received unsafe-make-signal-received)
(1/unsafe-make-signal-received unsafe-make-signal-received)
(1/unsafe-poll-ctx-eventmask-wakeup
unsafe-poll-ctx-eventmask-wakeup)
(1/unsafe-poll-ctx-fd-wakeup unsafe-poll-ctx-fd-wakeup)
@ -38734,10 +38734,13 @@
unsafe-signal-received
(lambda ()
(begin (|#%app| rktio_signal_received (unsafe-place-local-ref cell.1))))))
(define unsafe-make-signal-received
(lambda ()
(let ((rktio_0 (unsafe-place-local-ref cell.1)))
(lambda () (|#%app| rktio_signal_received rktio_0)))))
(define 1/unsafe-make-signal-received
(|#%name|
unsafe-make-signal-received
(lambda ()
(begin
(let ((rktio_0 (unsafe-place-local-ref cell.1)))
(lambda () (|#%app| rktio_signal_received rktio_0)))))))
(define 1/unsafe-set-sleep-in-thread!
(|#%name|
unsafe-set-sleep-in-thread!

371
racket/src/cs/schemified/schemify.scm
View File

@ -21199,6 +21199,46 @@
(let ((or-part_0 (number? val_1)))
(if or-part_0 or-part_0 (char? val_1)))))
(let ((val_0 (unwrap e_0))) (number? val_0))))))
(define always-eq/no-marks?
(lambda (e1_0 e2_0 mutated_0)
(let ((hd_0
(let ((p_0 (unwrap e1_0))) (if (pair? p_0) (unwrap (car p_0)) #f))))
(if (if (eq? 'quote hd_0)
(let ((a_0 (cdr (unwrap e1_0))))
(let ((p_0 (unwrap a_0)))
(if (pair? p_0)
(let ((a_1 (cdr p_0)))
(begin-unsafe
(let ((app_0 (unwrap '()))) (eq? app_0 (unwrap a_1)))))
#f)))
#f)
(let ((v1_0
(let ((d_0 (cdr (unwrap e1_0))))
(let ((a_0 (car (unwrap d_0)))) a_0))))
(let ((hd_1
(let ((p_0 (unwrap e2_0)))
(if (pair? p_0) (unwrap (car p_0)) #f))))
(if (if (eq? 'quote hd_1)
(let ((a_0 (cdr (unwrap e2_0))))
(let ((p_0 (unwrap a_0)))
(if (pair? p_0)
(let ((a_1 (cdr p_0)))
(begin-unsafe
(let ((app_0 (unwrap '())))
(eq? app_0 (unwrap a_1)))))
#f)))
#f)
(let ((v2_0
(let ((d_0 (cdr (unwrap e2_0))))
(let ((a_0 (car (unwrap d_0)))) a_0))))
(eq? v1_0 v2_0))
#f)))
(let ((u-e1_0 (unwrap e1_0)))
(if (symbol? u-e1_0)
(if (eq? u-e1_0 (unwrap e2_0))
(simple-mutated-state? (hash-ref mutated_0 u-e1_0 #f))
#f)
#f))))))
(define unnest-let
(lambda (e_0
prim-knowns_0
@ -28305,57 +28345,286 @@
prim-knowns_0
imports_0
mutated_0)))
(if (if authentic-key?_0
(simple?.1
#f
#t
#f
s-body_0
prim-knowns_0
knowns_1
imports_0
mutated_0
simples_0
unsafe-mode?_0)
#f)
(let ((app_0
(ensure-single-valued
s-key_0
knowns_1
prim-knowns_0
imports_0
mutated_0)))
(list
'begin
app_0
(ensure-single-valued
s-val_0
knowns_1
prim-knowns_0
imports_0
mutated_0)
s-body_0))
(if (eq?
target_0
'cify)
(list
'with-continuation-mark
s-key_0
s-val_0
s-body_0)
(let ((mode_0
(if (eq?
wcm-state_2
'fresh)
(if authentic-key?_0
'push-authentic
'push)
(if authentic-key?_0
'authentic
'general))))
(list
'with-continuation-mark*
mode_0
(let ((build-wcm_0
(|#%name|
build-wcm
(lambda (s-key_1
s-val_1
s-body_1)
(begin
(if (eq?
target_0
'cify)
(list
'with-continuation-mark
s-key_1
s-val_1
s-body_1)
(let ((mode_0
(if (eq?
wcm-state_2
'fresh)
(if authentic-key?_0
'push-authentic
'push)
(if authentic-key?_0
'authentic
'general))))
(list
'with-continuation-mark*
mode_0
s-key_1
s-val_1
s-body_1))))))))
(let ((build-begin_0
(|#%name|
build-begin
(lambda (s-key_1
s-val_1
s-body_1)
(begin
(if (if (simple?.1
#f
#t
1
s-key_1
prim-knowns_0
knowns_1
imports_0
mutated_0
simples_0
unsafe-mode?_0)
(simple?.1
#f
#t
1
s-val_1
prim-knowns_0
knowns_1
imports_0
mutated_0
simples_0
unsafe-mode?_0)
#f)
s-body_1
(let ((app_0
(ensure-single-valued
s-key_1
knowns_1
prim-knowns_0
imports_0
mutated_0)))
(list
'begin
app_0
(ensure-single-valued
s-val_1
knowns_1
prim-knowns_0
imports_0
mutated_0)
s-body_1))))))))
(if authentic-key?_0
(if (simple?.1
#f
#t
#f
s-body_0
prim-knowns_0
knowns_1
imports_0
mutated_0
simples_0
unsafe-mode?_0)
(build-begin_0
s-key_0
s-val_0
s-body_0)
(let ((hd_1
(let ((p_0
(unwrap
s-body_0)))
(if (pair?
p_0)
(unwrap
(car
p_0))
#f))))
(if (if (eq?
'with-continuation-mark*
hd_1)
(let ((a_0
(cdr
(unwrap
s-body_0))))
(let ((p_0
(unwrap
a_0)))
(if (pair?
p_0)
(let ((a_1
(cdr
p_0)))
(let ((p_1
(unwrap
a_1)))
(if (pair?
p_1)
(let ((a_2
(cdr
p_1)))
(let ((p_2
(unwrap
a_2)))
(if (pair?
p_2)
(let ((a_3
(cdr
p_2)))
(let ((p_3
(unwrap
a_3)))
(if (pair?
p_3)
(let ((a_4
(cdr
p_3)))
(begin-unsafe
(let ((app_0
(unwrap
'())))
(eq?
app_0
(unwrap
a_4)))))
#f)))
#f)))
#f)))
#f)))
#f)
(call-with-values
(lambda ()
(let ((d_0
(cdr
(unwrap
s-body_0))))
(let ((p_0
(unwrap
d_0)))
(let ((mode2_0
(let ((a_0
(car
p_0)))
a_0)))
(call-with-values
(lambda ()
(let ((d_1
(cdr
p_0)))
(let ((p_1
(unwrap
d_1)))
(let ((s-key2_0
(let ((a_0
(car
p_1)))
a_0)))
(call-with-values
(lambda ()
(let ((d_2
(cdr
p_1)))
(let ((p_2
(unwrap
d_2)))
(let ((s-val2_0
(let ((a_0
(car
p_2)))
a_0)))
(let ((s-body2_0
(let ((d_3
(cdr
p_2)))
(let ((a_0
(car
(unwrap
d_3))))
a_0))))
(let ((s-val2_1
s-val2_0))
(values
s-val2_1
s-body2_0)))))))
(case-lambda
((s-val2_0
s-body2_0)
(let ((s-key2_1
s-key2_0))
(values
s-key2_1
s-val2_0
s-body2_0)))
(args
(raise-binding-result-arity-error
2
args))))))))
(case-lambda
((s-key2_0
s-val2_0
s-body2_0)
(let ((mode2_1
mode2_0))
(values
mode2_1
s-key2_0
s-val2_0
s-body2_0)))
(args
(raise-binding-result-arity-error
3
args))))))))
(case-lambda
((mode2_0
s-key2_0
s-val2_0
s-body2_0)
(if (if (always-eq/no-marks?
s-key_0
s-key2_0
mutated_0)
(simple?.1
#f
#t
1
s-val2_0
prim-knowns_0
knowns_1
imports_0
mutated_0
simples_0
unsafe-mode?_0)
#f)
(build-begin_0
s-key_0
s-val_0
(build-wcm_0
s-key2_0
s-val2_0
s-body2_0))
(build-wcm_0
s-key_0
s-val_0
s-body_0)))
(args
(raise-binding-result-arity-error
4
args))))
(build-wcm_0
s-key_0
s-val_0
s-body_0))))
(build-wcm_0
s-key_0
s-val_0
s-body_0)))))))))

22
racket/src/schemify/equal.rkt
View File

@ -1,13 +1,15 @@
#lang racket/base
(require "wrap.rkt"
"match.rkt")
"match.rkt"
"mutated-state.rkt")
;; Since a Racket `equal?` will shadow the host Scheme's `equal?`,
;; its optimizer won't be able to reduce `equal?` to `eq?` or `eqv?`
;; with obvious arguments. So, we perform that conversion in schemify.
(provide equal-implies-eq?
equal-implies-eqv?)
equal-implies-eqv?
always-eq/no-marks?)
(define (equal-implies-eq? e)
(match e
@ -38,3 +40,19 @@
[`,val
(let ([val (unwrap val)])
(number? val))]))
;; e1 and e2 have been simplified;
;; return #t only if e2 doesn't try to
;; consult continuation marks
(define (always-eq/no-marks? e1 e2 mutated)
(match e1
[`(quote ,v1)
(match e2
[`(quote ,v2)
(eq? v1 v2)]
[`,_ #f])]
[`,_
(define u-e1 (unwrap e1))
(and (symbol? u-e1)
(eq? u-e1 (unwrap e2))
(simple-mutated-state? (hash-ref mutated u-e1 #f)))]))

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

@ -659,20 +659,51 @@
(define s-body (schemify body 'marked))
(define authentic-key?
(authentic-valued? key knowns prim-knowns imports mutated))
(define (build-wcm s-key s-val s-body)
(cond
[(aim? target '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)]))
(define (build-begin s-key s-val s-body)
(cond
[(and (simple? s-key prim-knowns knowns imports mutated simples unsafe-mode?)
(simple? s-val prim-knowns knowns imports mutated simples unsafe-mode?))
;; Avoid `begin` wrapper to help further `with-continuation-mark` optimizations
s-body]
[else
`(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated)
,(ensure-single-valued s-val knowns prim-knowns imports mutated)
,s-body)]))
(cond
[(and authentic-key?
(simple? s-body prim-knowns knowns imports mutated simples unsafe-mode? #:result-arity #f))
`(begin ,(ensure-single-valued s-key knowns prim-knowns imports mutated)
,(ensure-single-valued s-val knowns prim-knowns imports mutated)
,s-body)]
[(aim? target 'cify)
`(with-continuation-mark ,s-key ,s-val ,s-body)]
[authentic-key?
(cond
[(simple? s-body prim-knowns knowns imports mutated simples unsafe-mode? #:result-arity #f)
(build-begin s-key s-val s-body)]
[else
;; Simplify (with-continuation-mark <same-key> <val1>
;; (with-continuation-mark <same-key> <val2>
;; <body>)
;; to (begin <same-key> <val1>
;; (with-continuation-mark <same-key> <val2>
;; <body>))
;; as long as <same-key> and <val2> don't use marks
(match s-body
[`(with-continuation-mark* ,mode2 ,s-key2 ,s-val2 ,s-body2)
(cond
[(and (always-eq/no-marks? s-key s-key2 mutated)
(simple? s-val2 prim-knowns knowns imports mutated simples unsafe-mode?))
(build-begin s-key s-val
;; rebuild to use current `wcm-state`:
(build-wcm s-key2 s-val2 s-body2))]
[else (build-wcm s-key s-val s-body)])]
[`,_ (build-wcm 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)])]
(build-wcm s-key s-val s-body)])]
[`(begin ,exp)
(schemify exp wcm-state)]
[`(begin ,exps ...)

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

@ -10,7 +10,7 @@
;; Check whether an expression is simple in the sense that its order
;; of evaluation isn't detectable (`pure?` = #t) or at least it won't
;; try to capture a comtinuation (`pure?` = #f). In `pure?` mode, if
;; try to capture a continuation (`pure?` = #f). In `pure?` mode, if
;; `no-alloc?` is true, then allocation counts as detectable (for
;; ordering with respect to functions that might capture a continuation).
;; This function receives both schemified and non-schemified expressions.

2
racket/src/version/racket_version.h
View File

@ -16,7 +16,7 @@
#define MZSCHEME_VERSION_X 8
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_W 5
/* A level of indirection makes `#` work as needed: */
#define AS_a_STR_HELPER(x) #x