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