mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

Wire up new closure conversion pass

Browse source 
* module/language/cps/compile-bytecode.scm (compile-bytecode): Only
  convert closures if the #:cps2-convert? option is not passed.

* module/language/cps2/compile-cps.scm (conts->fun*, compile-cps): Add
  support for CPS2 closure conversion, disabled by default.
This commit is contained in:
Andy Wingo 2015-07-15 09:43:33 +02:00
parent 285f62a077
commit 981802c4c2
2 changed files with 26 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/language/cps/compile-bytecode.scm
View file

@ -517,7 +517,9 @@
;; ;;
;; (set! exp (optimize exp opts)) ;; (set! exp (optimize exp opts))
(set! exp (convert-closures exp)) (set! exp (if (not (kw-arg-ref opts #:cps2-convert? #f))
(convert-closures exp)
exp))
;; first-order optimization should go here ;; first-order optimization should go here
(set! exp (reify-primitives exp)) (set! exp (reify-primitives exp))
(set! exp (renumber exp)) (set! exp (renumber exp))

27
module/language/cps2/compile-cps.scm
View file

@ -27,6 +27,7 @@
#:use-module (language cps2) #:use-module (language cps2)
#:use-module ((language cps) #:prefix cps:) #:use-module ((language cps) #:prefix cps:)
#:use-module (language cps2 utils) #:use-module (language cps2 utils)
#:use-module (language cps2 closure-conversion)
#:use-module (language cps2 optimize) #:use-module (language cps2 optimize)
#:use-module (language cps2 renumber) #:use-module (language cps2 renumber)
#:use-module (language cps intmap) #:use-module (language cps intmap)
@ -34,7 +35,7 @@
;; Precondition: For each function in CONTS, the continuation names are ;; Precondition: For each function in CONTS, the continuation names are
;; topologically sorted. ;; topologically sorted.
(define (conts->fun conts) (define* (conts->fun conts #:optional (kfun 0))
(define (convert-fun kfun) (define (convert-fun kfun)
(let ((doms (compute-dom-edges (compute-idoms conts kfun)))) (let ((doms (compute-dom-edges (compute-idoms conts kfun))))
(define (visit-cont label) (define (visit-cont label)
@ -97,8 +98,26 @@
(($ $kfun src meta self tail clause) (($ $kfun src meta self tail clause)
(kfun (cps:$kfun src meta self (tail (cps:$ktail)) (kfun (cps:$kfun src meta self (tail (cps:$ktail))
,(visit-clause clause))))))) ,(visit-clause clause)))))))
(convert-fun 0)) (convert-fun kfun))
(define (conts->fun* conts)
(cps:build-cps-term
(cps:$program
,(intmap-fold-right (lambda (label cont out)
(match cont
(($ $kfun)
(cons (conts->fun conts label) out))
(_ out)))
conts
'()))))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (compile-cps exp env opts) (define (compile-cps exp env opts)
(let ((exp (renumber (optimize-higher-order-cps exp opts)))) (let ((exp (optimize-higher-order-cps exp opts)))
(values (conts->fun exp) env env))) (if (kw-arg-ref opts #:cps2-convert? #f)
(values (conts->fun* (renumber (convert-closures exp))) env env)
(values (conts->fun (renumber exp)) env env))))