From fa3b6e57c2e1d8f20a9c54bed3f3052f33a2b428 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Oct 2013 21:07:27 +0200 Subject: [PATCH] New pass: inline-constructors * module/Makefile.am: * module/language/cps/constructors.scm (inline-constructors): New pass. * module/language/cps/compile-rtl.scm (optimize): Call the new pass. * module/language/tree-il/compile-cps.scm (convert): Don't handle "list" specially here. --- module/Makefile.am | 1 + module/language/cps/compile-rtl.scm | 4 +- module/language/cps/constructors.scm | 98 +++++++++++++++++++++++++ module/language/tree-il/compile-cps.scm | 23 ++---- 4 files changed, 109 insertions(+), 17 deletions(-) create mode 100644 module/language/cps/constructors.scm diff --git a/module/Makefile.am b/module/Makefile.am index b3e573bc6..79bada4ae 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -123,6 +123,7 @@ CPS_LANG_SOURCES = \ language/cps/arities.scm \ language/cps/closure-conversion.scm \ language/cps/compile-rtl.scm \ + language/cps/constructors.scm \ language/cps/contification.scm \ language/cps/dfg.scm \ language/cps/primitives.scm \ diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm index ea697e2ac..88c9a4430 100644 --- a/module/language/cps/compile-rtl.scm +++ b/module/language/cps/compile-rtl.scm @@ -30,6 +30,7 @@ #:use-module (language cps arities) #:use-module (language cps closure-conversion) #:use-module (language cps contification) + #:use-module (language cps constructors) #:use-module (language cps dfg) #:use-module (language cps primitives) #:use-module (language cps reify-primitives) @@ -52,7 +53,8 @@ exp)) ;; Calls to source-to-source optimization passes go here. - (let* ((exp (run-pass exp contify #:contify? #t))) + (let* ((exp (run-pass exp contify #:contify? #t)) + (exp (run-pass exp inline-constructors #:inline-constructors? #t))) ;; Passes that are needed: ;; ;; * Abort contification: turning abort primcalls into continuation diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm new file mode 100644 index 000000000..b8d4e9639 --- /dev/null +++ b/module/language/cps/constructors.scm @@ -0,0 +1,98 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013 Free Software Foundation, Inc. + +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Constructor inlining turns "list" primcalls into a series of conses, +;;; and does similar transformations for "vector". +;;; +;;; Code: + +(define-module (language cps constructors) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:export (inline-constructors)) + +(define (inline-constructors fun) + (define (visit-cont cont) + (rewrite-cps-cont cont + (($ $cont sym src ($ $kargs names syms body)) + (sym src ($kargs names syms ,(visit-term body)))) + (($ $cont sym src ($ $kentry self tail clauses)) + (sym src ($kentry self ,tail ,(map visit-cont clauses)))) + (($ $cont sym src ($ $kclause arity body)) + (sym src ($kclause ,arity ,(visit-cont body)))) + (($ $cont) + ,cont))) + (define (visit-term term) + (rewrite-cps-term term + (($ $letk conts body) + ($letk ,(map visit-cont conts) + ,(visit-term body))) + (($ $letrec names syms funs body) + ($letrec names syms (map inline-constructors funs) + ,(visit-term body))) + (($ $continue k ($ $primcall 'list args)) + ,(let-gensyms (kvalues val) + (build-cps-term + ($letk ((kvalues #f ($kargs ('val) (val) + ($continue k + ($primcall 'values (val)))))) + ,(let lp ((args args) (k kvalues)) + (match args + (() + (build-cps-term + ($continue k ($const '())))) + ((arg . args) + (let-gensyms (ktail tail) + (build-cps-term + ($letk ((ktail #f ($kargs ('tail) (tail) + ($continue k + ($primcall 'cons (arg tail)))))) + ,(lp args ktail))))))))))) + (($ $continue k ($ $primcall 'vector args)) + ,(let-gensyms (kalloc vec len init) + (define (initialize args n) + (match args + (() + (build-cps-term + ($continue k ($primcall 'values (vec))))) + ((arg . args) + (let-gensyms (knext idx) + (build-cps-term + ($letk ((knext #f ($kargs () () + ,(initialize args (1+ n))))) + ($letconst (('idx idx n)) + ($continue knext + ($primcall 'vector-set! (vec idx arg)))))))))) + (build-cps-term + ($letk ((kalloc #f ($kargs ('vec) (vec) + ,(initialize args 0)))) + ($letconst (('len len (length args)) + ('init init #f)) + ($continue kalloc + ($primcall 'make-vector (len init)))))))) + (($ $continue k (and fun ($ $fun))) + ($continue k ,(inline-constructors fun))) + (($ $continue) + ,term))) + + (rewrite-cps-exp fun + (($ $fun meta free body) + ($fun meta free ,(visit-cont body))))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 6202e1230..f26b188bb 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -332,22 +332,13 @@ (build-cps-term ($continue k ($call proc args))))))) (($ src 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) - (build-cps-term ($continue k ($primcall 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) + (build-cps-term ($continue k ($primcall name args))))))) ;; Prompts with inline handlers. (($ src escape-only? tag body