Commit | Line | Data |
---|---|---|
b275fb26 AW |
1 | ;;; Tree-il canonicalizer |
2 | ||
542aa859 | 3 | ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. |
b275fb26 AW |
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 | ;;; Code: | |
20 | ||
21 | (define-module (language tree-il canonicalize) | |
22 | #:use-module (language tree-il) | |
23 | #:use-module (ice-9 match) | |
24 | #:use-module (srfi srfi-1) | |
25 | #:export (canonicalize!)) | |
26 | ||
27 | (define (tree-il-any proc exp) | |
28 | (tree-il-fold (lambda (exp res) | |
29 | (or res (proc exp))) | |
30 | (lambda (exp res) | |
31 | (or res (proc exp))) | |
32 | (lambda (exp res) res) | |
33 | #f exp)) | |
34 | ||
35 | (define (canonicalize! x) | |
36 | (post-order! | |
37 | (lambda (x) | |
38 | (match x | |
b275fb26 AW |
39 | (($ <let> src () () () body) |
40 | body) | |
41 | (($ <letrec> src _ () () () body) | |
42 | body) | |
43 | (($ <fix> src () () () body) | |
44 | body) | |
45 | (($ <dynlet> src () () body) | |
46 | body) | |
47 | (($ <prompt> src tag body handler) | |
48 | (define (escape-only? handler) | |
49 | (match handler | |
50 | (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) | |
542aa859 AW |
51 | (not (tree-il-any (lambda (x) |
52 | (and (lexical-ref? x) | |
53 | (eq? (lexical-ref-gensym x) cont))) | |
54 | body))) | |
b275fb26 AW |
55 | (else #f))) |
56 | (define (thunk-application? x) | |
57 | (match x | |
ca128245 | 58 | (($ <call> _ |
b275fb26 AW |
59 | ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) |
60 | ()) #t) | |
61 | (_ #f))) | |
62 | (define (make-thunk-application body) | |
63 | (define thunk | |
64 | (make-lambda #f '() | |
65 | (make-lambda-case #f '() #f #f #f '() '() body #f))) | |
ca128245 | 66 | (make-call #f thunk '())) |
b275fb26 AW |
67 | |
68 | ;; This code has a nasty job to do: to ensure that either the | |
69 | ;; handler is escape-only, or the body is the application of a | |
70 | ;; thunk. Sad but true. | |
71 | (if (or (escape-only? handler) | |
72 | (thunk-application? body)) | |
73 | #f | |
74 | (make-prompt src tag (make-thunk-application body) handler))) | |
75 | (_ #f))) | |
76 | x)) |