module/language/cps/constructors.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; Constructor inlining turns "list" primcalls into a series of conses,
  22 ;;; and does similar transformations for "vector".
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps constructors)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-26)
  29   #:use-module (language cps)
  30   #:export (inline-constructors))
  31
  32 (define (inline-constructors fun)
  33   (define (visit-cont cont)
  34     (rewrite-cps-cont cont
  35       (($ $cont sym ($ $kargs names syms body))
  36        (sym ($kargs names syms ,(visit-term body))))
  37       (($ $cont sym ($ $kentry self tail clauses))
  38        (sym ($kentry self ,tail ,(map visit-cont clauses))))
  39       (($ $cont sym ($ $kclause arity body))
  40        (sym ($kclause ,arity ,(visit-cont body))))
  41       (($ $cont)
  42        ,cont)))
  43   (define (visit-term term)
  44     (rewrite-cps-term term
  45       (($ $letk conts body)
  46        ($letk ,(map visit-cont conts)
  47          ,(visit-term body)))
  48       (($ $letrec names syms funs body)
  49        ($letrec names syms (map inline-constructors funs)
  50                 ,(visit-term body)))
  51       (($ $continue k src ($ $primcall 'list args))
  52        ,(let-gensyms (kvalues val)
  53           (build-cps-term
  54             ($letk ((kvalues ($kargs ('val) (val)
  55                                ($continue k src
  56                                  ($primcall 'values (val))))))
  57               ,(let lp ((args args) (k kvalues))
  58                  (match args
  59                    (()
  60                     (build-cps-term
  61                       ($continue k src ($const '()))))
  62                    ((arg . args)
  63                     (let-gensyms (ktail tail)
  64                       (build-cps-term
  65                         ($letk ((ktail ($kargs ('tail) (tail)
  66                                          ($continue k src
  67                                            ($primcall 'cons (arg tail))))))
  68                           ,(lp args ktail)))))))))))
  69       (($ $continue k src ($ $primcall 'vector args))
  70        ,(let-gensyms (kalloc vec len init)
  71           (define (initialize args n)
  72             (match args
  73               (()
  74                (build-cps-term
  75                  ($continue k src ($primcall 'values (vec)))))
  76               ((arg . args)
  77                (let-gensyms (knext idx)
  78                  (build-cps-term
  79                    ($letk ((knext ($kargs () ()
  80                                     ,(initialize args (1+ n)))))
  81                      ($letconst (('idx idx n))
  82                        ($continue knext src
  83                          ($primcall 'vector-set! (vec idx arg))))))))))
  84           (build-cps-term
  85             ($letk ((kalloc ($kargs ('vec) (vec)
  86                               ,(initialize args 0))))
  87               ($letconst (('len len (length args))
  88                           ('init init #f))
  89                 ($continue kalloc src
  90                   ($primcall 'make-vector (len init))))))))
  91       (($ $continue k src (and fun ($ $fun)))
  92        ($continue k src ,(inline-constructors fun)))
  93       (($ $continue)
  94        ,term)))
  95
  96   (rewrite-cps-exp fun
  97     (($ $fun src meta free body)
  98      ($fun src meta free ,(visit-cont body)))))