module/language/cps/constructors.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014 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 ($ $kfun src meta self tail clause))
  38        (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
  39       (($ $cont sym ($ $kclause arity body alternate))
  40        (sym ($kclause ,arity ,(visit-cont body)
  41                       ,(and alternate (visit-cont alternate)))))
  42       (($ $cont)
  43        ,cont)))
  44   (define (visit-term term)
  45     (rewrite-cps-term term
  46       (($ $letk conts body)
  47        ($letk ,(map visit-cont conts)
  48          ,(visit-term body)))
  49       (($ $letrec names syms funs body)
  50        ($letrec names syms (map visit-fun funs)
  51          ,(visit-term body)))
  52       (($ $continue k src ($ $primcall 'list args))
  53        ,(let-fresh (kvalues) (val)
  54           (build-cps-term
  55             ($letk ((kvalues ($kargs ('val) (val)
  56                                ($continue k src
  57                                  ($primcall 'values (val))))))
  58               ,(let lp ((args args) (k kvalues))
  59                  (match args
  60                    (()
  61                     (build-cps-term
  62                       ($continue k src ($const '()))))
  63                    ((arg . args)
  64                     (let-fresh (ktail) (tail)
  65                       (build-cps-term
  66                         ($letk ((ktail ($kargs ('tail) (tail)
  67                                          ($continue k src
  68                                            ($primcall 'cons (arg tail))))))
  69                           ,(lp args ktail)))))))))))
  70       (($ $continue k src ($ $primcall 'vector args))
  71        ,(let-fresh (kalloc) (vec len init)
  72           (define (initialize args n)
  73             (match args
  74               (()
  75                (build-cps-term
  76                  ($continue k src ($primcall 'values (vec)))))
  77               ((arg . args)
  78                (let-fresh (knext) (idx)
  79                  (build-cps-term
  80                    ($letk ((knext ($kargs () ()
  81                                     ,(initialize args (1+ n)))))
  82                      ($letconst (('idx idx n))
  83                        ($continue knext src
  84                          ($primcall 'vector-set! (vec idx arg))))))))))
  85           (build-cps-term
  86             ($letk ((kalloc ($kargs ('vec) (vec)
  87                               ,(initialize args 0))))
  88               ($letconst (('len len (length args))
  89                           ('init init #f))
  90                 ($continue kalloc src
  91                   ($primcall 'make-vector (len init))))))))
  92       (($ $continue k src (and fun ($ $fun)))
  93        ($continue k src ,(visit-fun fun)))
  94       (($ $continue)
  95        ,term)))
  96   (define (visit-fun fun)
  97     (rewrite-cps-exp fun
  98       (($ $fun free body)
  99        ($fun free ,(inline-constructors* body)))))
 100
 101   (visit-cont fun))
 102
 103 (define (inline-constructors fun)
 104   (with-fresh-name-state fun
 105     (inline-constructors* fun)))