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

schemify: more determinism for lifted procedures

Browse Source 
A further repair to 6f919635da.
This commit is contained in:
Matthew Flatt 2019-12-05 15:56:32 -07:00
parent 898517107f
commit d7052da691
1 changed files with 24 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -621,25 +621,30 @@
;; Create bindings for lifted functions, adding new arguments ;; Create bindings for lifted functions, adding new arguments
;; as the functions are lifted ;; as the functions are lifted
(define (extract-lifted-bindings lifts empties) (define (extract-lifted-bindings lifts empties)
(define bindings (define liftables
(for/list ([(f proc) (in-hash lifts)] ;; Improve determinsism by sorting liftables:
#:when (liftable? proc)) (sort (for/list ([(f proc) (in-hash lifts)]
(let* ([new-args (liftable-frees proc)] #:when (liftable? proc))
[frees (for/hash ([arg (in-list new-args)]) (cons f proc))
(values arg #t))] symbol<?
[rhs (liftable-expr proc)]) #:key car))
`[,f ,(match rhs (for/list ([f+proc (in-list liftables)])
[`(lambda ,args . ,body) (let* ([f (car f+proc)]
(let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees empties)]) [proc (cdr f+proc)]
(reannotate rhs `(lambda ,(append new-args args) . ,body)))] [new-args (liftable-frees proc)]
[`(case-lambda [,argss . ,bodys] ...) [frees (for/hash ([arg (in-list new-args)])
(reannotate rhs `(case-lambda (values arg #t))]
,@(for/list ([args (in-list argss)] [rhs (liftable-expr proc)])
[body (in-list bodys)]) `[,f ,(match rhs
(let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees empties)]) [`(lambda ,args . ,body)
`[,(append new-args args) . ,body]))))])]))) (let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees empties)])
;; Improve determinsism: (reannotate rhs `(lambda ,(append new-args args) . ,body)))]
(sort bindings symbol<? #:key car)) [`(case-lambda [,argss . ,bodys] ...)
(reannotate rhs `(case-lambda
,@(for/list ([args (in-list argss)]
[body (in-list bodys)])
(let ([body (convert-lifted-calls-in-seq/box-mutated body args lifts frees empties)])
`[,(append new-args args) . ,body]))))])])))
;; ---------------------------------------- ;; ----------------------------------------
;; Helpers ;; Helpers