module/language/cps/elide-values.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 ;;; Primcalls that don't correspond to VM instructions are treated as if
  22 ;;; they are calls, and indeed the later reify-primitives pass turns
  23 ;;; them into calls.  Because no return arity checking is done for these
  24 ;;; primitives, if a later optimization pass simplifies the primcall to
  25 ;;; a VM operation, the tail of the simplification has to be a
  26 ;;; primcall to 'values.  Most of these primcalls can be elided, and
  27 ;;; that is the job of this pass.
  28 ;;;
  29 ;;; Code:
  30
  31 (define-module (language cps elide-values)
  32   #:use-module (ice-9 match)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (language cps)
  35   #:use-module (language cps dfg)
  36   #:export (elide-values))
  37
  38 (define (elide-values* fun conts)
  39   (define (visit-cont cont)
  40     (rewrite-cps-cont cont
  41       (($ $cont sym ($ $kargs names syms body))
  42        (sym ($kargs names syms ,(visit-term body))))
  43       (($ $cont sym ($ $kfun src meta self tail clause))
  44        (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
  45       (($ $cont sym ($ $kclause arity body alternate))
  46        (sym ($kclause ,arity ,(visit-cont body)
  47                       ,(and alternate (visit-cont alternate)))))
  48       (($ $cont)
  49        ,cont)))
  50   (define (visit-term term)
  51     (rewrite-cps-term term
  52       (($ $letk conts body)
  53        ($letk ,(map visit-cont conts)
  54          ,(visit-term body)))
  55       (($ $letrec names syms funs body)
  56        ($letrec names syms (map visit-fun funs)
  57          ,(visit-term body)))
  58       (($ $continue k src ($ $primcall 'values vals))
  59        ,(rewrite-cps-term (vector-ref conts k)
  60           (($ $ktail)
  61            ($continue k src ($values vals)))
  62           (($ $kreceive ($ $arity req () rest () #f) kargs)
  63            ,(cond
  64              ((and (not rest) (= (length vals) (length req)))
  65               (build-cps-term
  66                 ($continue kargs src ($values vals))))
  67              ((and rest (>= (length vals) (length req)))
  68               (let-fresh (krest) (rest)
  69                 (let ((vals* (append (list-head vals (length req))
  70                                      (list rest))))
  71                   (build-cps-term
  72                     ($letk ((krest ($kargs ('rest) (rest)
  73                                      ($continue kargs src
  74                                        ($values vals*)))))
  75                       ,(let lp ((tail (list-tail vals (length req)))
  76                                 (k krest))
  77                          (match tail
  78                            (()
  79                             (build-cps-term ($continue k src
  80                                               ($const '()))))
  81                            ((v . tail)
  82                             (let-fresh (krest) (rest)
  83                               (build-cps-term
  84                                 ($letk ((krest ($kargs ('rest) (rest)
  85                                                  ($continue k src
  86                                                    ($primcall 'cons
  87                                                               (v rest))))))
  88                                   ,(lp tail krest))))))))))))
  89              (else term)))
  90           (($ $kargs args)
  91            ,(if (< (length vals) (length args))
  92                 term
  93                 (let ((vals (list-head vals (length args))))
  94                   (build-cps-term
  95                     ($continue k src ($values vals))))))))
  96       (($ $continue k src (and fun ($ $fun)))
  97        ($continue k src ,(visit-fun fun)))
  98       (($ $continue)
  99        ,term)))
 100   (define (visit-fun fun)
 101     (rewrite-cps-exp fun
 102       (($ $fun free cont)
 103        ($fun free ,(visit-cont cont)))))
 104
 105   (visit-cont fun))
 106
 107 (define (elide-values fun)
 108   (with-fresh-name-state fun
 109     (let ((conts (build-cont-table fun)))
 110       (elide-values* fun conts))))