Mercurial > urweb

annotate src/reduce.sml @ 159:1e382d10e832

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Abstracting datatypes with signature ascription
author Adam Chlipala <adamc@hcoop.net>
date Thu, 24 Jul 2008 16:41:12 -0400
parents 7420fa18d657
children 8a70e2919e86
rev   line source
adamc@20 1 (* Copyright (c) 2008, Adam Chlipala
adamc@20 2 * All rights reserved.
adamc@20 3 *
adamc@20 4 * Redistribution and use in source and binary forms, with or without
adamc@20 5 * modification, are permitted provided that the following conditions are met:
adamc@20 6 *
adamc@20 7 * - Redistributions of source code must retain the above copyright notice,
adamc@20 8 * this list of conditions and the following disclaimer.
adamc@20 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@20 10 * this list of conditions and the following disclaimer in the documentation
adamc@20 11 * and/or other materials provided with the distribution.
adamc@20 12 * - The names of contributors may not be used to endorse or promote products
adamc@20 13 * derived from this software without specific prior written permission.
adamc@20 14 *
adamc@20 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@20 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@20 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@20 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@20 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@20 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@20 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@20 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@20 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@20 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@20 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@20 26 *)
adamc@20 27
adamc@20 28 (* Simplify a Core program algebraically *)
adamc@20 29
adamc@20 30 structure Reduce :> REDUCE = struct
adamc@20 31
adamc@20 32 open Core
adamc@20 33
adamc@20 34 structure E = CoreEnv
adamc@20 35 structure U = CoreUtil
adamc@20 36
adamc@20 37 val liftConInCon = E.liftConInCon
adamc@20 38
adamc@20 39 val subConInCon =
adamc@20 40 U.Con.mapB {kind = fn k => k,
adamc@20 41 con = fn (xn, rep) => fn c =>
adamc@20 42 case c of
adamc@20 43 CRel xn' =>
adamc@74 44 (case Int.compare (xn', xn) of
adamc@74 45 EQUAL => #1 rep
adamc@74 46 | GREATER => CRel (xn' - 1)
adamc@74 47 | LESS => c)
adamc@20 48 | _ => c,
adamc@20 49 bind = fn ((xn, rep), U.Con.Rel _) => (xn+1, liftConInCon 0 rep)
adamc@20 50 | (ctx, _) => ctx}
adamc@20 51
adamc@21 52 val liftExpInExp =
adamc@21 53 U.Exp.mapB {kind = fn k => k,
adamc@21 54 con = fn _ => fn c => c,
adamc@21 55 exp = fn bound => fn e =>
adamc@21 56 case e of
adamc@21 57 ERel xn =>
adamc@21 58 if xn < bound then
adamc@21 59 e
adamc@21 60 else
adamc@21 61 ERel (xn + 1)
adamc@21 62 | _ => e,
adamc@21 63 bind = fn (bound, U.Exp.RelE _) => bound + 1
adamc@21 64 | (bound, _) => bound}
adamc@21 65
adamc@21 66 val subExpInExp =
adamc@21 67 U.Exp.mapB {kind = fn k => k,
adamc@21 68 con = fn _ => fn c => c,
adamc@21 69 exp = fn (xn, rep) => fn e =>
adamc@21 70 case e of
adamc@21 71 ERel xn' =>
adamc@74 72 (case Int.compare (xn', xn) of
adamc@74 73 EQUAL => #1 rep
adamc@74 74 | GREATER=> ERel (xn' - 1)
adamc@74 75 | LESS => e)
adamc@21 76 | _ => e,
adamc@21 77 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adamc@21 78 | (ctx, _) => ctx}
adamc@21 79
adamc@21 80 val liftConInExp =
adamc@21 81 U.Exp.mapB {kind = fn k => k,
adamc@21 82 con = fn bound => fn c =>
adamc@21 83 case c of
adamc@21 84 CRel xn =>
adamc@21 85 if xn < bound then
adamc@21 86 c
adamc@21 87 else
adamc@21 88 CRel (xn + 1)
adamc@21 89 | _ => c,
adamc@21 90 exp = fn _ => fn e => e,
adamc@21 91 bind = fn (bound, U.Exp.RelC _) => bound + 1
adamc@21 92 | (bound, _) => bound}
adamc@21 93
adamc@21 94 val subConInExp =
adamc@21 95 U.Exp.mapB {kind = fn k => k,
adamc@21 96 con = fn (xn, rep) => fn c =>
adamc@21 97 case c of
adamc@21 98 CRel xn' =>
adamc@74 99 (case Int.compare (xn', xn) of
adamc@74 100 EQUAL => #1 rep
adamc@74 101 | GREATER => CRel (xn' - 1)
adamc@74 102 | LESS => c)
adamc@21 103 | _ => c,
adamc@21 104 exp = fn _ => fn e => e,
adamc@21 105 bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep)
adamc@21 106 | (ctx, _) => ctx}
adamc@21 107
adamc@20 108 fun bindC (env, b) =
adamc@20 109 case b of
adamc@20 110 U.Con.Rel (x, k) => E.pushCRel env x k
adamc@20 111 | U.Con.Named (x, n, k, co) => E.pushCNamed env x n k co
adamc@20 112
adamc@20 113 fun bind (env, b) =
adamc@20 114 case b of
adamc@20 115 U.Decl.RelC (x, k) => E.pushCRel env x k
adamc@20 116 | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
adamc@20 117 | U.Decl.RelE (x, t) => E.pushERel env x t
adamc@109 118 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
adamc@20 119
adamc@20 120 fun kind k = k
adamc@20 121
adamc@20 122 fun con env c =
adamc@20 123 case c of
adamc@70 124 CApp ((CApp ((CApp ((CFold ks, _), f), _), i), loc), (CRecord (k, xcs), _)) =>
adamc@70 125 (case xcs of
adamc@70 126 [] => #1 i
adamc@70 127 | (n, v) :: rest =>
adamc@70 128 #1 (reduceCon env (CApp ((CApp ((CApp (f, n), loc), v), loc),
adamc@70 129 (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc),
adamc@70 130 (CRecord (k, rest), loc)), loc)), loc)))
adamc@70 131 | CApp ((CAbs (_, _, c1), loc), c2) =>
adamc@20 132 #1 (reduceCon env (subConInCon (0, c2) c1))
adamc@20 133 | CNamed n =>
adamc@20 134 (case E.lookupCNamed env n of
adamc@20 135 (_, _, SOME c') => #1 c'
adamc@20 136 | _ => c)
adamc@20 137 | CConcat ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => CRecord (k, xcs1 @ xcs2)
adamc@20 138 | _ => c
adamc@20 139
adamc@20 140 and reduceCon env = U.Con.mapB {kind = kind, con = con, bind = bindC} env
adamc@20 141
adamc@21 142 fun exp env e =
adamc@21 143 case e of
adamc@21 144 ENamed n =>
adamc@21 145 (case E.lookupENamed env n of
adamc@109 146 (_, _, SOME e', _) => #1 e'
adamc@21 147 | _ => e)
adamc@21 148
adamc@74 149 | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) =>
adamc@74 150 (case xcs of
adamc@74 151 [] => #1 i
adamc@74 152 | (n, v) :: rest =>
adamc@74 153 #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc),
adamc@74 154 (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc),
adamc@74 155 (CRecord (k, rest), loc)), loc)), loc)))
adamc@74 156
adamc@26 157 | EApp ((EAbs (_, _, _, e1), loc), e2) =>
adamc@21 158 #1 (reduceExp env (subExpInExp (0, e2) e1))
adamc@21 159 | ECApp ((ECAbs (_, _, e1), loc), c) =>
adamc@21 160 #1 (reduceExp env (subConInExp (0, c) e1))
adamc@21 161
adamc@22 162 | EField ((ERecord xes, _), (CName x, _), _) =>
adamc@29 163 (case List.find (fn ((CName x', _), _, _) => x' = x
adamc@22 164 | _ => false) xes of
adamc@29 165 SOME (_, e, _) => #1 e
adamc@22 166 | NONE => e)
adamc@149 167 | ECut (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) =>
adamc@149 168 let
adamc@149 169 fun fields (remaining, passed) =
adamc@149 170 case remaining of
adamc@149 171 [] => []
adamc@149 172 | (x, t) :: rest =>
adamc@149 173 (x,
adamc@149 174 (EField (r, x, {field = t,
adamc@149 175 rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc),
adamc@149 176 t) :: fields (rest, (x, t) :: passed)
adamc@149 177 in
adamc@149 178 #1 (reduceExp env (ERecord (fields (xts, [])), loc))
adamc@149 179 end
adamc@22 180
adamc@21 181 | _ => e
adamc@21 182
adamc@21 183 and reduceExp env = U.Exp.mapB {kind = kind, con = con, exp = exp, bind = bind} env
adamc@20 184
adamc@20 185 fun decl env d = d
adamc@20 186
adamc@133 187 val reduce = U.File.mapB {kind = kind, con = con, exp = exp, decl = decl, bind = bind} E.empty
adamc@20 188
adamc@20 189 end