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