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)
  39   (let ((conts (build-local-cont-table
  40                 (match fun (($ $fun src meta free body) body)))))
  41     (define (visit-cont cont)
  42       (rewrite-cps-cont cont
  43         (($ $cont sym ($ $kargs names syms body))
  44          (sym ($kargs names syms ,(visit-term body))))
  45         (($ $cont sym ($ $kentry self tail clauses))
  46          (sym ($kentry self ,tail ,(map visit-cont clauses))))
  47         (($ $cont sym ($ $kclause arity body))
  48          (sym ($kclause ,arity ,(visit-cont body))))
  49         (($ $cont)
  50          ,cont)))
  51     (define (visit-term term)
  52       (rewrite-cps-term term
  53         (($ $letk conts body)
  54          ($letk ,(map visit-cont conts)
  55            ,(visit-term body)))
  56         (($ $letrec names syms funs body)
  57          ($letrec names syms (map elide-values* funs)
  58                   ,(visit-term body)))
  59         (($ $continue k src ($ $primcall 'values vals))
  60          ,(rewrite-cps-term (lookup-cont k conts)
  61             (($ $ktail)
  62              ($continue k src ($values vals)))
  63             (($ $kreceive ($ $arity req () rest () #f) kargs)
  64              ,(cond
  65                ((and (not rest) (= (length vals) (length req)))
  66                 (build-cps-term
  67                   ($continue kargs src ($values vals))))
  68                ((and rest (>= (length vals) (length req)))
  69                 (let-fresh (krest) (rest)
  70                   (let ((vals* (append (list-head vals (length req))
  71                                        (list rest))))
  72                     (build-cps-term
  73                       ($letk ((krest ($kargs ('rest) (rest)
  74                                        ($continue kargs src
  75                                          ($values vals*)))))
  76                         ,(let lp ((tail (list-tail vals (length req)))
  77                                   (k krest))
  78                            (match tail
  79                              (()
  80                               (build-cps-term ($continue k src
  81                                                 ($const '()))))
  82                              ((v . tail)
  83                               (let-fresh (krest) (rest)
  84                                 (build-cps-term
  85                                   ($letk ((krest ($kargs ('rest) (rest)
  86                                                    ($continue k src
  87                                                      ($primcall 'cons
  88                                                                 (v rest))))))
  89                                     ,(lp tail krest))))))))))))
  90                (else term)))
  91             (($ $kargs args)
  92              ,(if (< (length vals) (length args))
  93                   term
  94                   (let ((vals (list-head vals (length args))))
  95                     (build-cps-term
  96                       ($continue k src ($values vals))))))))
  97         (($ $continue k src (and fun ($ $fun)))
  98          ($continue k src ,(elide-values* fun)))
  99         (($ $continue)
 100          ,term)))
 101
 102     (rewrite-cps-exp fun
 103       (($ $fun src meta free body)
 104        ($fun src meta free ,(visit-cont body))))))
 105
 106 (define (elide-values fun)
 107   (with-fresh-name-state fun
 108     (elide-values* fun)))