1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013 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-clause-arities clause)
36 (let ((conts (build-local-cont-table clause))
38 (($ $cont _ ($ $kentry _ ($ $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 fix-arities funs) ,(visit-term body)))
45 (($ $continue k src exp)
46 ,(visit-exp k src exp))))
48 (define (adapt-exp nvals k src exp)
51 (rewrite-cps-term (lookup-cont k conts)
53 ,(let-gensyms (kvoid kunspec unspec)
55 ($letk* ((kunspec ($kargs (unspec) (unspec)
57 ($primcall 'return (unspec)))))
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))
66 ,(let-gensyms (kvoid kvalues void)
68 ($letk* ((kvalues ($kargs ('void) (void)
70 ($primcall 'values (void)))))
72 ($continue kvalues src
74 ($continue kvoid src ,exp)))))))
76 ($continue k src ,exp))
80 ($letk ((k* ($kargs () () ($continue k src ($void)))))
81 ($continue k* src ,exp)))))))
83 (rewrite-cps-term (lookup-cont k conts)
85 ,(rewrite-cps-term exp
87 ($continue ktail src ($primcall 'return (sym))))
91 ($letk ((k* ($kargs (v) (v)
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))
100 ,(let-gensyms (kvalues value)
102 ($letk ((kvalues ($kargs ('value) (value)
104 ($primcall 'values (value))))))
105 ($continue kvalues src ,exp)))))))
107 ,(let-gensyms (k* drop)
109 ($letk ((k* ($kargs ('drop) (drop)
110 ($continue k src ($values ())))))
111 ($continue k* src ,exp)))))
113 ($continue k src ,exp))))))
115 (define (visit-exp k src exp)
116 (rewrite-cps-term exp
121 ,(adapt-exp 1 k src exp))
123 ,(adapt-exp 1 k src (fix-arities exp)))
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 'struct-set! (obj pos val))
138 ;; Unhappily, and undocumentedly, struct-set! returns the value
139 ;; that was set. There is code that relies on this. Hackety
141 ,(rewrite-cps-term (lookup-cont k conts)
143 ,(let-gensyms (kvoid)
145 ($letk* ((kvoid ($kargs () ()
147 ($primcall 'return (val))))))
148 ($continue kvoid src ,exp)))))
149 (($ $ktrunc arity kargs)
150 ,(rewrite-cps-term arity
151 (($ $arity () () #f () #f)
152 ($continue kargs src ,exp))
154 ,(let-gensyms (kvoid)
156 ($letk* ((kvoid ($kargs () ()
158 ($primcall 'values (val))))))
159 ($continue kvoid src ,exp)))))))
161 ($continue k src ,exp))
165 ($letk ((k* ($kargs () () ($continue k src ($var val)))))
166 ($continue k* src ,exp)))))))
167 (($ $primcall name args)
168 ,(match (prim-arity name)
170 (if (= in (length args))
172 (let ((inst (prim-rtl-instruction name)))
173 (if (and inst (not (eq? inst name)))
174 (build-cps-exp ($primcall inst args))
178 ($letk ((k* ($kargs ('prim) (p*)
179 ($continue k src ($call p* args)))))
180 ($continue k* src ($prim name)))))))))
182 ;; Values nodes are inserted by CPS optimization passes, so
183 ;; we assume they are correct.
184 ($continue k src ,exp))
186 ($continue k src ,exp))))
188 (define (visit-cont cont)
189 (rewrite-cps-cont cont
190 (($ $cont sym ($ $kargs names syms body))
191 (sym ($kargs names syms ,(visit-term body))))
192 (($ $cont sym ($ $kclause arity body))
193 (sym ($kclause ,arity ,(visit-cont body))))
197 (rewrite-cps-cont clause
198 (($ $cont sym ($ $kentry self tail clauses))
199 (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
201 (define (fix-arities fun)
203 (($ $fun src meta free body)
204 ($fun src meta free ,(fix-clause-arities body)))))