diff options
| author | Mark H Weaver <mhw@netris.org> | 2013-08-15 23:14:19 -0400 |
|---|---|---|
| committer | Mark H Weaver <mhw@netris.org> | 2013-08-15 23:14:19 -0400 |
| commit | 6a3e82845ed52dfd3e7711ba4a759091d7b8c2a4 (patch) | |
| tree | 3ce9c86ce02ee3c43a682006ceac432148ad6526 | |
| parent | 1bbe826fed721a4cfc1b1a9f7cc2052a5e646d7e (diff) | |
| download | guile-6a3e82845ed52dfd3e7711ba4a759091d7b8c2a4.tar.gz | |
RTL Compiler: Convert 'list' primcall into nested 'cons' primcalls.
* module/language/tree-il/compile-cps.scm (convert): Convert 'list'
primcalls into nested 'cons' primcalls before conversion to CPS.
| -rw-r--r-- | module/language/tree-il/compile-cps.scm | 31 |
1 files changed, 20 insertions, 11 deletions
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 16b058b05..e0b72bc82 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -23,7 +23,7 @@ (define-module (language tree-il compile-cps) #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (fold filter-map)) + #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map)) #:use-module (srfi srfi-26) #:use-module ((system foreign) #:select (make-pointer pointer->scm)) #:use-module (language cps) @@ -42,7 +42,7 @@ <lambda> <lambda-case> <let> <letrec> <fix> <let-values> <prompt> <abort> - make-conditional make-const + make-conditional make-const make-primcall tree-il-src tree-il-fold)) #:export (compile-cps)) @@ -318,15 +318,24 @@ (build-cps-term ($continue k ($call proc args))))))) (($ <primcall> src name args) - (if (branching-primitive? name) - (convert (make-conditional src exp (make-const #f #t) - (make-const #f #f)) - k subst) - (convert-args args - (lambda (args) - (if (eq? name 'values) - (build-cps-term ($continue k ($values args))) - (build-cps-term ($continue k ($primcall name args)))))))) + (case name + ((list) + (convert (fold-right (lambda (elem tail) + (make-primcall src 'cons + (list elem tail))) + (make-const src '()) + args) + k subst)) + (else + (if (branching-primitive? name) + (convert (make-conditional src exp (make-const #f #t) + (make-const #f #f)) + k subst) + (convert-args args + (lambda (args) + (if (eq? name 'values) + (build-cps-term ($continue k ($values args))) + (build-cps-term ($continue k ($primcall name args)))))))))) ;; Prompts with inline handlers. (($ <prompt> src escape-only? tag body |