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 | |
39 | (($ <sequence> src (tail)) | |
40 | tail) | |
41 | (($ <sequence> src exps) | |
42 | (and (any sequence? exps) | |
43 | (make-sequence src | |
44 | (append-map (lambda (x) | |
45 | (if (sequence? x) | |
46 | (sequence-exps x) | |
47 | (list x))) | |
48 | exps)))) | |
49 | (($ <let> src () () () body) | |
50 | body) | |
51 | (($ <letrec> src _ () () () body) | |
52 | body) | |
53 | (($ <fix> src () () () body) | |
54 | body) | |
55 | (($ <dynlet> src () () body) | |
56 | body) | |
57 | (($ <prompt> src tag body handler) | |
58 | (define (escape-only? handler) | |
59 | (match handler | |
60 | (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) | |
542aa859 AW |
61 | (not (tree-il-any (lambda (x) |
62 | (and (lexical-ref? x) | |
63 | (eq? (lexical-ref-gensym x) cont))) | |
64 | body))) | |
b275fb26 AW |
65 | (else #f))) |
66 | (define (thunk-application? x) | |
67 | (match x | |
68 | (($ <application> _ | |
69 | ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) | |
70 | ()) #t) | |
71 | (_ #f))) | |
72 | (define (make-thunk-application body) | |
73 | (define thunk | |
74 | (make-lambda #f '() | |
75 | (make-lambda-case #f '() #f #f #f '() '() body #f))) | |
76 | (make-application #f thunk '())) | |
77 | ||
78 | ;; This code has a nasty job to do: to ensure that either the | |
79 | ;; handler is escape-only, or the body is the application of a | |
80 | ;; thunk. Sad but true. | |
81 | (if (or (escape-only? handler) | |
82 | (thunk-application? body)) | |
83 | #f | |
84 | (make-prompt src tag (make-thunk-application body) handler))) | |
85 | (_ #f))) | |
86 | x)) |