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