diff options
Diffstat (limited to 'module/language/cps/constructors.scm')
| -rw-r--r-- | module/language/cps/constructors.scm | 104 |
1 files changed, 0 insertions, 104 deletions
diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm deleted file mode 100644 index bbe779d27..000000000 --- a/module/language/cps/constructors.scm +++ /dev/null @@ -1,104 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 ($ $kargs names syms body)) - (sym ($kargs names syms ,(visit-term body)))) - (($ $cont sym ($ $kfun src meta self tail clause)) - (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) - (($ $cont sym ($ $kclause arity body alternate)) - (sym ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont) - ,cont))) - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) - ,(visit-term body))) - (($ $continue k src ($ $primcall 'list args)) - ,(let-fresh (kvalues) (val) - (build-cps-term - ($letk ((kvalues ($kargs ('val) (val) - ($continue k src - ($primcall 'values (val)))))) - ,(let lp ((args args) (k kvalues)) - (match args - (() - (build-cps-term - ($continue k src ($const '())))) - ((arg . args) - (let-fresh (ktail) (tail) - (build-cps-term - ($letk ((ktail ($kargs ('tail) (tail) - ($continue k src - ($primcall 'cons (arg tail)))))) - ,(lp args ktail))))))))))) - (($ $continue k src ($ $primcall 'vector args)) - ,(let-fresh (kalloc) (vec len init) - (define (initialize args n) - (match args - (() - (build-cps-term - ($continue k src ($primcall 'values (vec))))) - ((arg . args) - (let-fresh (knext) (idx) - (build-cps-term - ($letk ((knext ($kargs () () - ,(initialize args (1+ n))))) - ($letconst (('idx idx n)) - ($continue knext src - ($primcall 'vector-set! (vec idx arg)))))))))) - (build-cps-term - ($letk ((kalloc ($kargs ('vec) (vec) - ,(initialize args 0)))) - ($letconst (('len len (length args)) - ('init init #f)) - ($continue kalloc src - ($primcall 'make-vector (len init)))))))) - (($ $continue k src (and fun ($ $fun))) - ($continue k src ,(visit-fun fun))) - (($ $continue k src ($ $rec names syms funs)) - ($continue k src ($rec names syms (map visit-fun funs)))) - (($ $continue) - ,term))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(inline-constructors* body))))) - - (visit-cont fun)) - -(define (inline-constructors fun) - (with-fresh-name-state fun - (inline-constructors* fun))) |