module/language/cps/elide-values.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 ;;; 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 ;;; an RTL 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             (($ $ktrunc ($ $arity req () rest () #f) kargs)
  64              ,(if (or rest (< (length vals) (length req)))
  65                   term
  66                   (let ((vals (list-head vals (length req))))
  67                     (build-cps-term
  68                       ($continue kargs src ($values vals))))))
  69             (($ $kargs args)
  70              ,(if (< (length vals) (length args))
  71                   term
  72                   (let ((vals (list-head vals (length args))))
  73                     (build-cps-term
  74                       ($continue k src ($values vals))))))))
  75         (($ $continue k src (and fun ($ $fun)))
  76          ($continue k src ,(elide-values fun)))
  77         (($ $continue)
  78          ,term)))
  79
  80     (rewrite-cps-exp fun
  81       (($ $fun src meta free body)
  82        ($fun src meta free ,(visit-cont body))))))