adamc@20: (* Copyright (c) 2008, Adam Chlipala adamc@20: * All rights reserved. adamc@20: * adamc@20: * Redistribution and use in source and binary forms, with or without adamc@20: * modification, are permitted provided that the following conditions are met: adamc@20: * adamc@20: * - Redistributions of source code must retain the above copyright notice, adamc@20: * this list of conditions and the following disclaimer. adamc@20: * - Redistributions in binary form must reproduce the above copyright notice, adamc@20: * this list of conditions and the following disclaimer in the documentation adamc@20: * and/or other materials provided with the distribution. adamc@20: * - The names of contributors may not be used to endorse or promote products adamc@20: * derived from this software without specific prior written permission. adamc@20: * adamc@20: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@20: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@20: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@20: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@20: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@20: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@20: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@20: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@20: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@20: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@20: * POSSIBILITY OF SUCH DAMAGE. adamc@20: *) adamc@20: adamc@20: (* Simplify a Core program algebraically *) adamc@20: adamc@20: structure Reduce :> REDUCE = struct adamc@20: adamc@20: open Core adamc@20: adamc@20: structure E = CoreEnv adamc@20: structure U = CoreUtil adamc@20: adamc@20: val liftConInCon = E.liftConInCon adamc@193: val subConInCon = E.subConInCon adamc@417: val liftConInExp = E.liftConInExp adamc@20: adamc@21: val liftExpInExp = adamc@21: U.Exp.mapB {kind = fn k => k, adamc@21: con = fn _ => fn c => c, adamc@21: exp = fn bound => fn e => adamc@21: case e of adamc@21: ERel xn => adamc@21: if xn < bound then adamc@21: e adamc@21: else adamc@21: ERel (xn + 1) adamc@21: | _ => e, adamc@21: bind = fn (bound, U.Exp.RelE _) => bound + 1 adamc@21: | (bound, _) => bound} adamc@21: adamc@21: val subExpInExp = adamc@21: U.Exp.mapB {kind = fn k => k, adamc@21: con = fn _ => fn c => c, adamc@21: exp = fn (xn, rep) => fn e => adamc@21: case e of adamc@21: ERel xn' => adamc@74: (case Int.compare (xn', xn) of adamc@74: EQUAL => #1 rep adamc@74: | GREATER=> ERel (xn' - 1) adamc@74: | LESS => e) adamc@21: | _ => e, adamc@21: bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) adamc@417: | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) adamc@21: | (ctx, _) => ctx} adamc@21: adamc@315: val liftConInExp = E.liftConInExp adamc@315: val subConInExp = E.subConInExp adamc@21: adamc@20: fun bindC (env, b) = adamc@20: case b of adamc@20: U.Con.Rel (x, k) => E.pushCRel env x k adamc@20: | U.Con.Named (x, n, k, co) => E.pushCNamed env x n k co adamc@20: adamc@20: fun bind (env, b) = adamc@20: case b of adamc@20: U.Decl.RelC (x, k) => E.pushCRel env x k adamc@20: | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co adamc@20: | U.Decl.RelE (x, t) => E.pushERel env x t adamc@109: | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s adamc@20: adamc@20: fun kind k = k adamc@20: adamc@20: fun con env c = adamc@20: case c of adamc@70: CApp ((CApp ((CApp ((CFold ks, _), f), _), i), loc), (CRecord (k, xcs), _)) => adamc@70: (case xcs of adamc@70: [] => #1 i adamc@70: | (n, v) :: rest => adamc@70: #1 (reduceCon env (CApp ((CApp ((CApp (f, n), loc), v), loc), adamc@70: (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc), adamc@70: (CRecord (k, rest), loc)), loc)), loc))) adamc@70: | CApp ((CAbs (_, _, c1), loc), c2) => adamc@20: #1 (reduceCon env (subConInCon (0, c2) c1)) adamc@20: | CNamed n => adamc@20: (case E.lookupCNamed env n of adamc@20: (_, _, SOME c') => #1 c' adamc@20: | _ => c) adamc@20: | CConcat ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => CRecord (k, xcs1 @ xcs2) adamc@215: adamc@215: | CProj ((CTuple cs, _), n) => #1 (List.nth (cs, n - 1)) adamc@215: adamc@20: | _ => c adamc@20: adamc@20: and reduceCon env = U.Con.mapB {kind = kind, con = con, bind = bindC} env adamc@20: adamc@21: fun exp env e = adamc@417: let adamc@417: (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan))]*) adamc@21: adamc@417: val r = case e of adamc@417: ENamed n => adamc@417: (case E.lookupENamed env n of adamc@417: (_, _, SOME e', _) => #1 e' adamc@417: | _ => e) adamc@74: adamc@417: | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) => adamc@417: (case xcs of adamc@417: [] => #1 i adamc@417: | (n, v) :: rest => adamc@417: #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc), adamc@417: (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc), adamc@417: (CRecord (k, rest), loc)), loc)), loc))) adamc@21: adamc@417: | EApp ((EAbs (_, _, _, e1), loc), e2) => adamc@417: #1 (reduceExp env (subExpInExp (0, e2) e1)) adamc@417: | ECApp ((ECAbs (_, _, e1), loc), c) => adamc@417: #1 (reduceExp env (subConInExp (0, c) e1)) adamc@22: adamc@417: | EField ((ERecord xes, _), (CName x, _), _) => adamc@417: (case List.find (fn ((CName x', _), _, _) => x' = x adamc@417: | _ => false) xes of adamc@417: SOME (_, e, _) => #1 e adamc@417: | NONE => e) adamc@417: | EWith (r as (_, loc), x, e, {rest = (CRecord (k, xts), _), field}) => adamc@417: let adamc@417: fun fields (remaining, passed) = adamc@417: case remaining of adamc@417: [] => [] adamc@417: | (x, t) :: rest => adamc@417: (x, adamc@417: (EField (r, x, {field = t, adamc@417: rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc), adamc@417: t) :: fields (rest, (x, t) :: passed) adamc@417: in adamc@417: #1 (reduceExp env (ERecord ((x, e, field) :: fields (xts, [])), loc)) adamc@417: end adamc@417: | ECut (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) => adamc@417: let adamc@417: fun fields (remaining, passed) = adamc@417: case remaining of adamc@417: [] => [] adamc@417: | (x, t) :: rest => adamc@417: (x, adamc@417: (EField (r, x, {field = t, adamc@417: rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc), adamc@417: t) :: fields (rest, (x, t) :: passed) adamc@417: in adamc@417: #1 (reduceExp env (ERecord (fields (xts, [])), loc)) adamc@417: end adamc@417: adamc@417: | _ => e adamc@417: in adamc@417: (*Print.prefaces "exp'" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan)), adamc@417: ("r", CorePrint.p_exp env (r, ErrorMsg.dummySpan))];*) adamc@417: adamc@417: r adamc@417: end adamc@21: adamc@21: and reduceExp env = U.Exp.mapB {kind = kind, con = con, exp = exp, bind = bind} env adamc@20: adamc@330: fun decl env d = adamc@330: case d of adamc@330: DValRec [vi as (_, n, _, e, _)] => adamc@330: let adamc@330: fun kind _ = false adamc@330: fun con _ = false adamc@330: fun exp e = adamc@330: case e of adamc@330: ENamed n' => n' = n adamc@330: | _ => false adamc@330: in adamc@330: if U.Exp.exists {kind = kind, con = con, exp = exp} e then adamc@330: d adamc@330: else adamc@330: DVal vi adamc@330: end adamc@330: | _ => d adamc@20: adamc@133: val reduce = U.File.mapB {kind = kind, con = con, exp = exp, decl = decl, bind = bind} E.empty adamc@20: adamc@20: end