Mercurial > urweb

comparison src/fuse.sml @ 506:65d8541c130b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fusing writes with recursive function calls
author Adam Chlipala <adamc@hcoop.net>
date Tue, 25 Nov 2008 10:05:44 -0500
parents
children 3f3b211f9bca
comparison
equal deleted inserted replaced
505:e18c747dd945 506:65d8541c130b
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 structure Fuse :> FUSE = struct
29
30 open Mono
31 structure U = MonoUtil
32
33 structure IM = IntBinaryMap
34
35 fun returnsString (t, loc) =
36 let
37 fun rs (t, loc) =
38 case t of
39 TFfi ("Basis", "string") => SOME ([], (TRecord [], loc))
40 | TFun (dom, ran) =>
41 (case rs ran of
42 NONE => NONE
43 | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
44 | _ => NONE
45 in
46 case t of
47 TFun (dom, ran) =>
48 (case rs ran of
49 NONE => NONE
50 | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc)))
51 | _ => NONE
52 end
53
54 fun fuse file =
55 let
56 fun doDecl (d as (_, loc), (funcs, maxName)) =
57 let
58 val (d, funcs, maxName) =
59 case #1 d of
60 DValRec vis =>
61 let
62 val (vis', funcs, maxName) =
63 foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) =>
64 case returnsString t of
65 NONE => (vis', funcs, maxName)
66 | SOME (args, t') =>
67 let
68 fun getBody (e, args) =
69 case (#1 e, args) of
70 (_, []) => (e, [])
71 | (EAbs (x, t, _, e), _ :: args) =>
72 let
73 val (body, args') = getBody (e, args)
74 in
75 (body, (x, t) :: args')
76 end
77 | _ => raise Fail "Fuse: getBody"
78
79 val (body, args) = getBody (e, args)
80 val body = MonoOpt.optExp (EWrite body, loc)
81 val (body, _) = foldl (fn ((x, dom), (body, ran)) =>
82 ((EAbs (x, dom, ran, body), loc),
83 (TFun (dom, ran), loc)))
84 (body, (TRecord [], loc)) args
85 in
86 ((x, maxName, t', body, s) :: vis',
87 IM.insert (funcs, n, maxName),
88 maxName + 1)
89 end)
90 ([], funcs, maxName) vis
91 in
92 ((DValRec (vis @ vis'), loc), funcs, maxName)
93 end
94 | _ => (d, funcs, maxName)
95
96 fun exp e =
97 case e of
98 EWrite e' =>
99 let
100 fun unravel (e, loc) =
101 case e of
102 ENamed n =>
103 (case IM.find (funcs, n) of
104 NONE => NONE
105 | SOME n' => SOME (ENamed n', loc))
106 | EApp (e1, e2) =>
107 (case unravel e1 of
108 NONE => NONE
109 | SOME e1 => SOME (EApp (e1, e2), loc))
110 | _ => NONE
111 in
112 case unravel e' of
113 NONE => e
114 | SOME (e', _) => e'
115 end
116 | _ => e
117 in
118 (U.Decl.map {typ = fn x => x,
119 exp = exp,
120 decl = fn x => x}
121 d,
122 (funcs, maxName))
123 end
124
125 val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file
126 in
127 file
128 end
129
130 end