module/language/cps/arities.scm

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