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 kargs)
  62             ,(rewrite-cps-term arity
  63                (($ $arity () () #f () #f)
  64                 ($continue kargs ,exp))
  65                (_
  66                 ,(let-gensyms (kvoid kvalues void)
  67                    (build-cps-term
  68                      ($letk* ((kvalues #f ($kargs ('void) (void)
  69                                             ($continue k
  70                                               ($primcall 'values (void)))))
  71                               (kvoid #f ($kargs () ()
  72                                           ($continue kvalues
  73                                             ($void)))))
  74                        ($continue kvoid ,exp)))))))
  75            (($ $kargs () () _)
  76             ($continue k ,exp))
  77            (_
  78             ,(let-gensyms (k*)
  79                (build-cps-term
  80                  ($letk ((k* #f ($kargs () () ($continue k ($void)))))
  81                    ($continue k* ,exp)))))))
  82         (1
  83          (rewrite-cps-term (lookup-cont k conts)
  84            (($ $ktail)
  85             ,(rewrite-cps-term exp
  86                (($var sym)
  87                 ($continue ktail ($primcall 'return (sym))))
  88                (_
  89                 ,(let-gensyms (k* v)
  90                    (build-cps-term
  91                      ($letk ((k* #f ($kargs (v) (v)
  92                                       ($continue k
  93                                         ($primcall 'return (v))))))
  94                        ($continue k* ,exp)))))))
  95            (($ $ktrunc arity kargs)
  96             ,(rewrite-cps-term arity
  97                (($ $arity (_) () #f () #f)
  98                 ($continue kargs ,exp))
  99                (_
 100                 ,(let-gensyms (kvalues value)
 101                    (build-cps-term
 102                      ($letk ((kvalues #f ($kargs ('value) (value)
 103                                            ($continue k
 104                                              ($primcall 'values (value))))))
 105                        ($continue kvalues ,exp)))))))
 106            (($ $kargs () () _)
 107             ,(let-gensyms (k* drop)
 108                (build-cps-term
 109                  ($letk ((k* #f ($kargs ('drop) (drop)
 110                                   ($continue k ($values ())))))
 111                    ($continue k* ,exp)))))
 112            (_
 113             ($continue k ,exp))))))
 114
 115     (define (visit-exp k exp)
 116       (rewrite-cps-term exp
 117         ((or ($ $void)
 118              ($ $const)
 119              ($ $prim)
 120              ($ $var))
 121          ,(adapt-exp 1 k exp))
 122         (($ $fun)
 123          ,(adapt-exp 1 k (fix-arities exp)))
 124         (($ $call)
 125          ;; In general, calls have unknown return arity.  For that
 126          ;; reason every non-tail call has an implicit adaptor
 127          ;; continuation to adapt the return to the target
 128          ;; continuation, and we don't need to do any adapting here.
 129          ($continue k ,exp))
 130         (($ $primcall 'return (arg))
 131          ;; Primcalls to return are in tail position.
 132          ($continue ktail ,exp))
 133         (($ $primcall (? (lambda (name)
 134                            (and (not (prim-rtl-instruction name))
 135                                 (not (branching-primitive? name))))))
 136          ($continue k ,exp))
 137         (($ $primcall name args)
 138          ,(match (prim-arity name)
 139             ((out . in)
 140              (if (= in (length args))
 141                  (adapt-exp out k exp)
 142                  (let-gensyms (k* p*)
 143                    (build-cps-term
 144                      ($letk ((k* #f ($kargs ('prim) (p*)
 145                                       ($continue k ($call p* args)))))
 146                        ($continue k* ($prim name)))))))))
 147         (($ $values)
 148          ;; Values nodes are inserted by CPS optimization passes, so
 149          ;; we assume they are correct.
 150          ($continue k ,exp))
 151         (($ $prompt)
 152          ($continue k ,exp))))
 153
 154     (define (visit-cont cont)
 155       (rewrite-cps-cont cont
 156         (($ $cont sym src ($ $kargs names syms body))
 157          (sym src ($kargs names syms ,(visit-term body))))
 158         (($ $cont sym src ($ $kclause arity body))
 159          (sym src ($kclause ,arity ,(visit-cont body))))
 160         (($ $cont)
 161          ,cont)))
 162
 163     (rewrite-cps-cont clause
 164       (($ $cont sym src ($ $kentry self tail clauses))
 165        (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
 166
 167 (define (fix-arities fun)
 168   (rewrite-cps-exp fun
 169     (($ $fun meta free body)
 170      ($fun meta free ,(fix-clause-arities body)))))