module/language/cps/arities.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 ;;; A pass to adapt expressions to the arities of their continuations,
  22 ;;; and to rewrite some tail expressions as primcalls to "return".
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps arities)
  27   #:use-module (ice-9 match)
  28   #:use-module ((srfi srfi-1) #:select (fold))
  29   #:use-module (srfi srfi-26)
  30   #:use-module (language cps)
  31   #:use-module (language cps dfg)
  32   #:use-module (language cps primitives)
  33   #:export (fix-arities))
  34
  35 (define (fix-clause-arities clause)
  36   (let ((conts (build-local-cont-table clause))
  37         (ktail (match clause
  38                  (($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
  39     (define (visit-term term)
  40       (rewrite-cps-term term
  41         (($ $letk conts body)
  42          ($letk ,(map visit-cont conts) ,(visit-term body)))
  43         (($ $letrec names syms funs body)
  44          ($letrec names syms (map fix-arities funs) ,(visit-term body)))
  45         (($ $continue k exp)
  46          ,(visit-exp k exp))))
  47
  48     (define (adapt-exp nvals k exp)
  49       (match nvals
  50         (0
  51          (rewrite-cps-term (lookup-cont k conts)
  52            (($ $ktail)
  53             ,(let-gensyms (kvoid kunspec unspec)
  54                (build-cps-term
  55                  ($letk* ((kunspec #f ($kargs (unspec) (unspec)
  56                                         ($continue k
  57                                           ($primcall 'return (unspec)))))
  58                           (kvoid #f ($kargs () ()
  59                                       ($continue kunspec ($void)))))
  60                    ($continue kvoid ,exp)))))
  61            (($ $ktrunc ($ $arity () () #f () #f) kseq)
  62             ($continue kseq ,exp))
  63            (($ $kargs () () _)
  64             ($continue k ,exp))
  65            (_
  66             ,(let-gensyms (k*)
  67                (build-cps-term
  68                  ($letk ((k* #f ($kargs () () ($continue k ($void)))))
  69                    ($continue k* ,exp)))))))
  70         (1
  71          (let ((drop-result
  72                 (lambda (kseq)
  73                   (let-gensyms (k* drop)
  74                     (build-cps-term
  75                       ($letk ((k* #f ($kargs ('drop) (drop)
  76                                        ($continue kseq ($values ())))))
  77                         ($continue k* ,exp)))))))
  78            (rewrite-cps-term (lookup-cont k conts)
  79              (($ $ktail)
  80               ,(rewrite-cps-term exp
  81                  (($var sym)
  82                   ($continue ktail ($primcall 'return (sym))))
  83                  (_
  84                   ,(let-gensyms (k* v)
  85                      (build-cps-term
  86                        ($letk ((k* #f ($kargs (v) (v)
  87                                         ($continue k
  88                                           ($primcall 'return (v))))))
  89                          ($continue k* ,exp)))))))
  90              (($ $ktrunc ($ $arity () () #f () #f) kseq)
  91               ,(drop-result kseq))
  92              (($ $kargs () () _)
  93               ,(drop-result k))
  94              (_
  95               ($continue k ,exp)))))))
  96
  97     (define (visit-exp k exp)
  98       (rewrite-cps-term exp
  99         ((or ($ $void)
 100              ($ $const)
 101              ($ $prim)
 102              ($ $var))
 103          ,(adapt-exp 1 k exp))
 104         (($ $fun)
 105          ,(adapt-exp 1 k (fix-arities exp)))
 106         (($ $call)
 107          ;; In general, calls have unknown return arity.  For that
 108          ;; reason every non-tail call has an implicit adaptor
 109          ;; continuation to adapt the return to the target
 110          ;; continuation, and we don't need to do any adapting here.
 111          ($continue k ,exp))
 112         (($ $primcall 'return (arg))
 113          ;; Primcalls to return are in tail position.
 114          ($continue ktail ,exp))
 115         (($ $primcall (? (lambda (name)
 116                            (and (not (prim-rtl-instruction name))
 117                                 (not (branching-primitive? name))))))
 118          ($continue k ,exp))
 119         (($ $primcall name args)
 120          ,(match (prim-arity name)
 121             ((out . in)
 122              (if (= in (length args))
 123                  (adapt-exp out k exp)
 124                  (let-gensyms (k* p*)
 125                    (build-cps-term
 126                      ($letk ((k* #f ($kargs ('prim) (p*)
 127                                       ($continue k ($call p* args)))))
 128                        ($continue k* ($prim name)))))))))
 129         (($ $values)
 130          ;; Values nodes are inserted by CPS optimization passes, so
 131          ;; we assume they are correct.
 132          ($continue k ,exp))
 133         (($ $prompt)
 134          ($continue k ,exp))))
 135
 136     (define (visit-cont cont)
 137       (rewrite-cps-cont cont
 138         (($ $cont sym src ($ $kargs names syms body))
 139          (sym src ($kargs names syms ,(visit-term body))))
 140         (($ $cont sym src ($ $kclause arity body))
 141          (sym src ($kclause ,arity ,(visit-cont body))))
 142         (($ $cont)
 143          ,cont)))
 144
 145     (rewrite-cps-cont clause
 146       (($ $cont sym src ($ $kentry self tail clauses))
 147        (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
 148
 149 (define (fix-arities fun)
 150   (rewrite-cps-exp fun
 151     (($ $fun meta free body)
 152      ($fun meta free ,(fix-clause-arities body)))))