unbreak cify on "startup.inc"

Commit 7cbeebbb89 broke the input to cify, and eb73837baf uncovered a
different problem.
This commit is contained in:
Matthew Flatt 2018-08-14 20:29:32 -06:00
parent a25efeb8a9
commit facba8a6ab
5 changed files with 41 additions and 9 deletions

View File

@ -286,10 +286,14 @@
(out-open "if (~a_count != 1)" vals-id)
(return ret runstack #:can-omit? #t
(format "scheme_values(~a_count, (Scheme_Object **)~a)" vals-id (runstack-ref runstack vals-id)))
(out-close+open "else")
(return ret runstack #:can-omit? #t #:can-pre-pop? #t
(runstack-ref runstack vals-id))
(out-close!)
(cond
[(return-can-omit-single? ret)
(out-close!)]
[else
(out-close+open "else")
(return ret runstack #:can-omit? #t #:can-pre-pop? #t
(runstack-ref runstack vals-id))
(out-close!)])
(runstack-pop! runstack)
(out-close "}")]
[`(if ,orig-tst ,thn ,els)
@ -402,7 +406,7 @@
(hash-ref top-names id #f)))
"/*needed*/"
""))
(generate (multiple-return values-ret) `(begin . ,body1) env)
(generate (only-multiple-return values-ret) `(begin . ,body1) env)
(out-open "{")
(define bind-count
(for/sum ([id (in-list ids)]
@ -1041,7 +1045,7 @@
(generate (format "~a =" (top-ref #f id)) rhs #f #hasheq()
runstack knowns top-names state lambdas prim-names prim-knowns)]
[`(define-values (,ids ...) ,rhs)
(generate (multiple-return "/*needed*/") rhs #f #hasheq()
(generate (only-multiple-return "/*needed*/") rhs #f #hasheq()
runstack knowns top-names state lambdas prim-names prim-knowns)
(generate-multiple-value-binds ids runstack #f state top-names)]
[`,_

View File

@ -19,7 +19,8 @@
"union.rkt"
"debug.rkt")
(provide (rename-out [main-cify cify]))
(provide (rename-out [main-cify cify])
re-unique)
(define (main-cify out-file exports in-e prim-knowns
#:debug? [debug? #f]

View File

@ -3,12 +3,15 @@
(provide (struct-out tail-return)
(struct-out multiple-return)
(struct-out only-multiple-return)
(struct-out multiple-return/suffix)
return
return-can-omit?)
return-can-omit?
return-can-omit-single?)
(struct tail-return (function-id lam self-args leaf?))
(struct multiple-return (prefix))
(struct only-multiple-return multiple-return ())
(struct multiple-return/suffix multiple-return (generate-suffix))
(define (return ret runstack s
@ -41,3 +44,5 @@
(and (multiple-return? ret)
(equal? (multiple-return-prefix ret) ""))))
(define (return-can-omit-single? ret)
(only-multiple-return? ret))

View File

@ -67,6 +67,9 @@
[`(let . ,_) (re-unique-let e env)]
[`(letrec . ,_) (re-unique-let e env)]
[`(letrec* . ,_) (re-unique-let e env)]
;; Recognize `values` form so we can use this on schemify input, too
[`(let-values . ,_) (re-unique-let-values e env)]
[`(letrec-values . ,_) (re-unique-let-values e env)]
[`(set! ,id ,rhs)
`(set! ,(re-unique id env) ,(re-unique rhs env))]
[`(,rator ,rands ...)
@ -92,6 +95,20 @@
`[,id ,(re-unique rhs rhs-env)])
. ,(re-unique-body body body-env))]))
(define (re-unique-let-values e env)
(match e
[`(,let-values-id ([(,idss ...) ,rhss] ...) . ,body)
(define rec? (not (eq? let-values-id 'let-values)))
(define new-idss (map select-unique idss))
(define body-env (for/fold ([env env]) ([ids (in-list idss)]
[new-ids (in-list new-idss)])
(env-add env ids new-ids)))
(define rhs-env (if rec? body-env env))
`(,let-values-id ,(for/list ([ids (in-list new-idss)]
[rhs (in-list rhss)])
`[,ids ,(re-unique rhs rhs-env)])
. ,(re-unique-body body body-env))]))
(define (env-add env ids new-ids)
(cond
[(null? ids) env]

View File

@ -66,10 +66,15 @@
(define-values (bodys/constants-lifted lifted-constants)
(time (convert-for-serialize l #t)))
;; Startup code reuses names to keep it compact; make
;; te names unique again
(define bodys/re-uniqued
(cdr (re-unique `(begin . ,bodys/constants-lifted))))
(printf "Schemify...\n")
(define body
(time
(schemify-body bodys/constants-lifted prim-knowns #hasheq() #hasheq()
(schemify-body bodys/re-uniqued prim-knowns #hasheq() #hasheq()
;; for cify:
#t
;; unsafe mode: