Mercurial > urweb

annotate src/reduce.sml @ 20:1ab48e37d0ef

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Some con reducing
author Adam Chlipala <adamc@hcoop.net>
date Sun, 08 Jun 2008 15:47:44 -0400
parents
children 067029c748e9
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@20 44 if xn = xn' then
adamc@20 45 #1 rep
adamc@20 46 else
adamc@20 47 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@20 52 fun bindC (env, b) =
adamc@20 53 case b of
adamc@20 54 U.Con.Rel (x, k) => E.pushCRel env x k
adamc@20 55 | U.Con.Named (x, n, k, co) => E.pushCNamed env x n k co
adamc@20 56
adamc@20 57 fun bind (env, b) =
adamc@20 58 case b of
adamc@20 59 U.Decl.RelC (x, k) => E.pushCRel env x k
adamc@20 60 | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
adamc@20 61 | U.Decl.RelE (x, t) => E.pushERel env x t
adamc@20 62 | U.Decl.NamedE (x, n, t, eo) => E.pushENamed env x n t eo
adamc@20 63
adamc@20 64 fun kind k = k
adamc@20 65
adamc@20 66 fun con env c =
adamc@20 67 case c of
adamc@20 68 CApp ((CAbs (_, _, c1), loc), c2) =>
adamc@20 69 #1 (reduceCon env (subConInCon (0, c2) c1))
adamc@20 70 | CNamed n =>
adamc@20 71 (case E.lookupCNamed env n of
adamc@20 72 (_, _, SOME c') => #1 c'
adamc@20 73 | _ => c)
adamc@20 74 | CConcat ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => CRecord (k, xcs1 @ xcs2)
adamc@20 75 | _ => c
adamc@20 76
adamc@20 77 and reduceCon env = U.Con.mapB {kind = kind, con = con, bind = bindC} env
adamc@20 78
adamc@20 79 fun exp env e = e
adamc@20 80
adamc@20 81 fun decl env d = d
adamc@20 82
adamc@20 83 val reduce = U.File.mapB {kind = kind, con = con, exp = exp, decl = decl, bind = bind} CoreEnv.basis
adamc@20 84
adamc@20 85 end