1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
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.
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.
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
21 ;;; A pass to adapt expressions to the arities of their continuations,
22 ;;; and to rewrite some tail expressions as primcalls to "return".
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))
35 (define (fix-arities* clause dfg)
36 (let ((ktail (match clause
38 ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
39 (define (visit-term term)
40 (rewrite-cps-term term
42 ($letk ,(map visit-cont conts) ,(visit-term body)))
43 (($ $letrec names syms funs body)
44 ($letrec names syms (map (lambda (fun)
47 ($fun free ,(fix-arities* body dfg)))))
50 (($ $continue k src exp)
51 ,(visit-exp k src exp))))
53 (define (adapt-exp nvals k src exp)
56 (rewrite-cps-term (lookup-cont k dfg)
58 ,(let-fresh (kvoid kunspec) (unspec)
60 ($letk* ((kunspec ($kargs (unspec) (unspec)
62 ($primcall 'return (unspec)))))
64 ($continue kunspec src ($void)))))
65 ($continue kvoid src ,exp)))))
66 (($ $kreceive arity kargs)
68 (($ $arity () () rest () #f)
72 ($letk ((knil ($kargs () ()
73 ($continue kargs src ($const '())))))
74 ($continue knil src ,exp))))
76 ($continue kargs src ,exp))))
78 (let-fresh (kvoid kvalues) (void)
80 ($letk* ((kvalues ($kargs ('void) (void)
82 ($primcall 'values (void)))))
84 ($continue kvalues src
86 ($continue kvoid src ,exp)))))))
88 ($continue k src ,exp))
92 ($letk ((k* ($kargs () () ($continue k src ($void)))))
93 ($continue k* src ,exp)))))))
95 (rewrite-cps-term (lookup-cont k dfg)
97 ,(rewrite-cps-term exp
99 ($continue ktail src ($primcall 'return (sym))))
103 ($letk ((k* ($kargs (v) (v)
105 ($primcall 'return (v))))))
106 ($continue k* src ,exp)))))))
107 (($ $kreceive arity kargs)
109 (($ $arity (_) () rest () #f)
111 (let-fresh (kval) (val nil)
113 ($letk ((kval ($kargs ('val) (val)
114 ($letconst (('nil nil '()))
116 ($values (val nil)))))))
117 ($continue kval src ,exp))))
118 (build-cps-term ($continue kargs src ,exp))))
120 (let-fresh (kvalues) (value)
122 ($letk ((kvalues ($kargs ('value) (value)
124 ($primcall 'values (value))))))
125 ($continue kvalues src ,exp)))))))
127 ,(let-fresh (k*) (drop)
129 ($letk ((k* ($kargs ('drop) (drop)
130 ($continue k src ($values ())))))
131 ($continue k* src ,exp)))))
133 ($continue k src ,exp))))))
135 (define (visit-exp k src exp)
136 (rewrite-cps-term exp
141 ,(adapt-exp 1 k src exp))
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 (($ $primcall 'return (arg))
152 ;; Primcalls to return are in tail position.
153 ($continue ktail src ,exp))
154 (($ $primcall (? (lambda (name)
155 (and (not (prim-instruction name))
156 (not (branching-primitive? name))))))
157 ($continue k src ,exp))
158 (($ $primcall name args)
159 ,(match (prim-arity name)
161 (if (= in (length args))
163 (let ((inst (prim-instruction name)))
164 (if (and inst (not (eq? inst name)))
165 (build-cps-exp ($primcall inst args))
169 ($letk ((k* ($kargs ('prim) (p*)
170 ($continue k src ($call p* args)))))
171 ($continue k* src ($prim name)))))))))
173 ;; Non-unary values nodes are inserted by CPS optimization
174 ;; passes, so we assume they are correct.
175 ($continue k src ,exp))
177 ($continue k src ,exp))))
179 (define (visit-cont cont)
180 (rewrite-cps-cont cont
181 (($ $cont sym ($ $kargs names syms body))
182 (sym ($kargs names syms ,(visit-term body))))
183 (($ $cont sym ($ $kclause arity body alternate))
184 (sym ($kclause ,arity ,(visit-cont body)
185 ,(and alternate (visit-cont alternate)))))
189 (rewrite-cps-cont clause
190 (($ $cont sym ($ $kfun src meta self tail clause))
191 (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
193 (define (fix-arities fun)
194 (let ((dfg (compute-dfg fun)))
195 (with-fresh-name-state-from-dfg dfg
196 (fix-arities* fun dfg))))