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@508: structure IM = IntBinaryMap adamc@20: adamc@908: structure E = CoreEnv adamc@908: adamc@908: fun multiLiftExpInExp n e = adamc@908: if n = 0 then adamc@908: e adamc@908: else adamc@908: multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) adamc@908: adamc@909: val dangling = adamc@909: CoreUtil.Exp.existsB {kind = fn _ => false, adamc@909: con = fn _ => false, adamc@909: exp = fn (n, e) => adamc@909: case e of adamc@909: ERel n' => n' >= n adamc@909: | _ => false, adamc@909: bind = fn (n, b) => adamc@909: case b of adamc@909: CoreUtil.Exp.RelE _ => n + 1 adamc@909: | _ => n} adamc@909: adamc@508: datatype env_item = adamc@626: UnknownK adamc@626: | KnownK of kind adamc@626: adamc@626: | UnknownC adamc@508: | KnownC of con adamc@21: adamc@508: | UnknownE adamc@508: | KnownE of exp adamc@20: adamc@626: | Lift of int * int * int adamc@20: adamc@909: val edepth = foldl (fn (UnknownE, n) => n + 1 adamc@909: | (KnownE _, n) => n + 1 adamc@909: | (_, n) => n) 0 adamc@909: adamc@909: val edepth' = foldl (fn (UnknownE, n) => n + 1 adamc@909: | (KnownE _, n) => n + 1 adamc@909: | (Lift (_, _, n'), n) => n + n' adamc@909: | (_, n) => n) 0 adamc@909: adamc@508: type env = env_item list adamc@20: adamc@510: fun ei2s ei = adamc@510: case ei of adamc@626: UnknownK => "UK" adamc@626: | KnownK _ => "KK" adamc@626: | UnknownC => "UC" adamc@510: | KnownC _ => "KC" adamc@510: | UnknownE => "UE" adamc@510: | KnownE _ => "KE" adamc@626: | Lift (_, n1, n2) => "(" ^ Int.toString n1 ^ ", " ^ Int.toString n2 ^ ")" adamc@510: adamc@510: fun e2s env = String.concatWith " " (map ei2s env) adamc@510: adamc@909: (*val deKnown = List.filter (fn KnownC _ => false adamc@510: | KnownE _ => false adamc@626: | KnownK _ => false adamc@909: | _ => true)*) adamc@909: adamc@909: val deKnown = ListUtil.mapConcat (fn KnownC _ => [] adamc@909: | KnownE _ => [] adamc@909: | KnownK _ => [] adamc@909: | Lift (nk, nc, ne) => List.tabulate (nk, fn _ => UnknownK) adamc@909: @ List.tabulate (nc, fn _ => UnknownC) adamc@909: @ List.tabulate (ne, fn _ => UnknownE) adamc@909: | x => [x]) adamc@510: adamc@930: datatype result = Yes of env | No | Maybe adamc@930: adamc@930: fun match (env, p : pat, e : exp) = adamc@930: case (#1 p, #1 e) of adamc@930: (PWild, _) => Yes env adamc@930: | (PVar (x, t), _) => Yes (KnownE e :: env) adamc@930: adamc@930: | (PPrim p, EPrim p') => adamc@930: if Prim.equal (p, p') then adamc@930: Yes env adamc@930: else adamc@930: No adamc@930: adamc@930: | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) => adamc@930: if n1 = n2 then adamc@930: Yes env adamc@930: else adamc@930: No adamc@930: adamc@930: | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) => adamc@930: if n1 = n2 then adamc@930: match (env, p, e) adamc@930: else adamc@930: No adamc@930: adamc@930: | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE), adamc@930: ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) => adamc@930: if m1 = m2 andalso con1 = con2 then adamc@930: Yes env adamc@930: else adamc@930: No adamc@930: adamc@930: | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep), adamc@930: ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) => adamc@930: if m1 = m2 andalso con1 = con2 then adamc@930: match (env, p, e) adamc@930: else adamc@930: No adamc@930: adamc@930: | (PRecord xps, ERecord xes) => adamc@930: if List.exists (fn ((CName _, _), _, _) => false adamc@930: | _ => true) xes then adamc@930: Maybe adamc@930: else adamc@930: let adamc@930: fun consider (xps, env) = adamc@930: case xps of adamc@930: [] => Yes env adamc@930: | (x, p, _) :: rest => adamc@930: case List.find (fn ((CName x', _), _, _) => x' = x adamc@930: | _ => false) xes of adamc@930: NONE => No adamc@930: | SOME (_, e, _) => adamc@930: case match (env, p, e) of adamc@930: No => No adamc@930: | Maybe => Maybe adamc@930: | Yes env => consider (rest, env) adamc@930: in adamc@930: consider (xps, env) adamc@930: end adamc@930: adamc@930: | _ => Maybe adamc@930: adamc@626: fun kindConAndExp (namedC, namedE) = adamc@508: let adamc@626: fun kind env (all as (k, loc)) = adamc@626: case k of adamc@626: KType => all adamc@626: | KArrow (k1, k2) => (KArrow (kind env k1, kind env k2), loc) adamc@626: | KName => all adamc@626: | KRecord k => (KRecord (kind env k), loc) adamc@626: | KUnit => all adamc@626: | KTuple ks => (KTuple (map (kind env) ks), loc) adamc@626: adamc@626: | KRel n => adamc@626: let adamc@626: fun find (n', env, nudge, lift) = adamc@626: case env of adamc@626: [] => raise Fail "Reduce.kind: KRel" adamc@626: | UnknownC :: rest => find (n', rest, nudge, lift) adamc@626: | KnownC _ :: rest => find (n', rest, nudge, lift) adamc@626: | UnknownE :: rest => find (n', rest, nudge, lift) adamc@626: | KnownE _ :: rest => find (n', rest, nudge, lift) adamc@626: | Lift (lift', _, _) :: rest => find (n', rest, nudge + lift', lift + lift') adamc@626: | UnknownK :: rest => adamc@626: if n' = 0 then adamc@626: (KRel (n + nudge), loc) adamc@626: else adamc@626: find (n' - 1, rest, nudge, lift + 1) adamc@626: | KnownK k :: rest => adamc@626: if n' = 0 then adamc@626: kind (Lift (lift, 0, 0) :: rest) k adamc@626: else adamc@626: find (n' - 1, rest, nudge - 1, lift) adamc@626: in adamc@626: find (n, env, 0, 0) adamc@626: end adamc@626: | KFun (x, k) => (KFun (x, kind (UnknownK :: env) k), loc) adamc@626: adamc@508: fun con env (all as (c, loc)) = adamc@510: ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) adamc@508: case c of adamc@508: TFun (c1, c2) => (TFun (con env c1, con env c2), loc) adamc@626: | TCFun (x, k, c2) => (TCFun (x, kind env k, con (UnknownC :: env) c2), loc) adamc@626: | TKFun (x, c2) => (TKFun (x, con (UnknownK :: env) c2), loc) adamc@508: | TRecord c => (TRecord (con env c), loc) adamc@215: adamc@508: | CRel n => adamc@508: let adamc@626: fun find (n', env, nudge, liftK, liftC) = adamc@510: case env of adamc@510: [] => raise Fail "Reduce.con: CRel" adamc@626: | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC) adamc@626: | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC) adamc@626: | UnknownE :: rest => find (n', rest, nudge, liftK, liftC) adamc@626: | KnownE _ :: rest => find (n', rest, nudge, liftK, liftC) adamc@626: | Lift (liftK', liftC', _) :: rest => find (n', rest, nudge + liftC', adamc@626: liftK + liftK', liftC + liftC') adamc@510: | UnknownC :: rest => adamc@510: if n' = 0 then adamc@510: (CRel (n + nudge), loc) adamc@510: else adamc@626: find (n' - 1, rest, nudge, liftK, liftC + 1) adamc@510: | KnownC c :: rest => adamc@510: if n' = 0 then adamc@626: con (Lift (liftK, liftC, 0) :: rest) c adamc@510: else adamc@626: find (n' - 1, rest, nudge - 1, liftK, liftC) adamc@508: in adamc@510: (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) adamc@626: find (n, env, 0, 0, 0) adamc@508: end adamc@508: | CNamed n => adamc@508: (case IM.find (namedC, n) of adamc@508: NONE => all adamc@508: | SOME c => c) adamc@508: | CFfi _ => all adamc@508: | CApp (c1, c2) => adamc@508: let adamc@508: val c1 = con env c1 adamc@508: val c2 = con env c2 adamc@508: in adamc@508: case #1 c1 of adamc@508: CAbs (_, _, b) => adamc@510: con (KnownC c2 :: deKnown env) b adamc@215: adamc@621: | CApp ((CMap (dom, ran), _), f) => adamc@508: (case #1 c2 of adamc@626: CRecord (_, []) => (CRecord (kind env ran, []), loc) adamc@621: | CRecord (_, (x, c) :: rest) => adamc@510: con (deKnown env) adamc@621: (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc), adamc@626: (CApp (c1, (CRecord (kind env dom, rest), loc)), loc)), loc) adamc@508: | _ => (CApp (c1, c2), loc)) adamc@20: adamc@508: | _ => (CApp (c1, c2), loc) adamc@508: end adamc@626: | CAbs (x, k, b) => (CAbs (x, kind env k, con (UnknownC :: env) b), loc) adamc@626: adamc@626: | CKApp (c1, k) => adamc@626: let adamc@626: val c1 = con env c1 adamc@626: in adamc@626: case #1 c1 of adamc@626: CKAbs (_, b) => adamc@626: con (KnownK k :: deKnown env) b adamc@626: adamc@626: | _ => (CKApp (c1, kind env k), loc) adamc@626: end adamc@626: | CKAbs (x, b) => (CKAbs (x, con (UnknownK :: env) b), loc) adamc@20: adamc@508: | CName _ => all adamc@21: adamc@626: | CRecord (k, xcs) => (CRecord (kind env k, map (fn (x, c) => (con env x, con env c)) xcs), loc) adamc@508: | CConcat (c1, c2) => adamc@508: let adamc@508: val c1 = con env c1 adamc@508: val c2 = con env c2 adamc@508: in adamc@508: case (#1 c1, #1 c2) of adamc@508: (CRecord (k, xcs1), CRecord (_, xcs2)) => adamc@626: (CRecord (kind env k, xcs1 @ xcs2), loc) adamc@508: | _ => (CConcat (c1, c2), loc) adamc@508: end adamc@626: | CMap (dom, ran) => (CMap (kind env dom, kind env ran), loc) adamc@74: adamc@508: | CUnit => all adamc@21: adamc@508: | CTuple cs => (CTuple (map (con env) cs), loc) adamc@508: | CProj (c, n) => adamc@508: let adamc@508: val c = con env c adamc@508: in adamc@508: case #1 c of adamc@508: CTuple cs => List.nth (cs, n - 1) adamc@508: | _ => (CProj (c, n), loc) adamc@510: end) adamc@22: adamc@509: fun patCon pc = adamc@509: case pc of adamc@509: PConVar _ => pc adamc@509: | PConFfi {mod = m, datatyp, params, con = c, arg, kind} => adamc@509: PConFfi {mod = m, datatyp = datatyp, params = params, con = c, adamc@509: arg = Option.map (con (map (fn _ => UnknownC) params)) arg, adamc@509: kind = kind} adamc@509: adamc@509: adamc@509: val k = (KType, ErrorMsg.dummySpan) adamc@509: fun doPart e (this as (x, t), rest) = adamc@509: ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t), adamc@509: this :: rest) adamc@509: adamc@509: fun exp env (all as (e, loc)) = adamc@909: let adamc@909: (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), adamc@909: ("env", Print.PD.string (e2s env))]*) adamc@910: val () = if dangling (edepth env) all then adamc@909: (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), adamc@909: ("env", Print.PD.string (e2s env))]; adamc@909: raise Fail "!") adamc@909: else adamc@910: () adamc@509: adamc@909: val r = case e of adamc@909: EPrim _ => all adamc@909: | ERel n => adamc@909: let adamc@909: fun find (n', env, nudge, liftK, liftC, liftE) = adamc@909: case env of adamc@909: [] => raise Fail ("Reduce.exp: ERel (" ^ ErrorMsg.spanToString loc ^ ")") adamc@909: | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC, liftE) adamc@909: | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC, liftE) adamc@909: | UnknownC :: rest => find (n', rest, nudge, liftK, liftC + 1, liftE) adamc@909: | KnownC _ :: rest => find (n', rest, nudge, liftK, liftC, liftE) adamc@909: | Lift (liftK', liftC', liftE') :: rest => adamc@909: find (n', rest, nudge + liftE', adamc@909: liftK + liftK', liftC + liftC', liftE + liftE') adamc@909: | UnknownE :: rest => adamc@909: if n' = 0 then adamc@909: (ERel (n + nudge), loc) adamc@909: else adamc@909: find (n' - 1, rest, nudge, liftK, liftC, liftE + 1) adamc@909: | KnownE e :: rest => adamc@909: if n' = 0 then adamc@909: ((*print "SUBSTITUTING\n";*) adamc@909: exp (Lift (liftK, liftC, liftE) :: rest) e) adamc@909: else adamc@909: find (n' - 1, rest, nudge - 1, liftK, liftC, liftE) adamc@909: in adamc@909: (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) adamc@909: find (n, env, 0, 0, 0, 0) adamc@909: end adamc@909: | ENamed n => adamc@909: (case IM.find (namedE, n) of adamc@909: NONE => all adamc@909: | SOME e => e) adamc@909: | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, adamc@909: map (con env) cs, Option.map (exp env) eo), loc) adamc@909: | EFfi _ => all adamc@909: | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) adamc@908: adamc@909: (*| EApp ( adamc@909: (EApp adamc@909: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), adamc@909: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@909: (ECase (ed, pes, {disc, ...}), _)), _), adamc@909: trans2) => adamc@909: let adamc@909: val e' = (EFfi ("Basis", "bind"), loc) adamc@909: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@909: val e' = (ECApp (e', t1), loc) adamc@909: val e' = (ECApp (e', t2), loc) adamc@909: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@908: adamc@909: val pes = map (fn (p, e) => adamc@909: let adamc@909: val e' = (EApp (e', e), loc) adamc@909: val e' = (EApp (e', adamc@909: multiLiftExpInExp (E.patBindsN p) adamc@909: trans2), loc) adamc@909: val e' = exp env e' adamc@909: in adamc@909: (p, e') adamc@909: end) pes adamc@909: in adamc@909: (ECase (exp env ed, adamc@909: pes, adamc@909: {disc = con env disc, adamc@909: result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}), adamc@909: loc) adamc@909: end*) adamc@908: adamc@909: | EApp (e1, e2) => adamc@909: let adamc@910: val env' = deKnown env adamc@910: adamc@910: fun reassoc e = adamc@910: case #1 e of adamc@910: EApp adamc@910: ((EApp adamc@910: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), adamc@910: t1), adamc@910: _), t2), _), adamc@910: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@910: (EServerCall (n, es, (EAbs (_, _, _, ke), _), dom, ran), _)), _), adamc@910: trans3) => adamc@910: let adamc@910: val e' = (EFfi ("Basis", "bind"), loc) adamc@910: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@910: val e' = (ECApp (e', dom), loc) adamc@910: val e' = (ECApp (e', t2), loc) adamc@910: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@910: val e' = (EApp (e', ke), loc) adamc@910: val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) adamc@910: val e' = reassoc e' adamc@910: val e' = (EAbs ("x", dom, t2, e'), loc) adamc@910: val e' = (EServerCall (n, es, e', dom, t2), loc) adamc@910: in adamc@910: e' adamc@910: end adamc@910: adamc@910: | EApp adamc@910: ((EApp adamc@910: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), adamc@910: t1), adamc@910: _), t2), _), adamc@910: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@910: (EServerCall (n, es, ke, dom, ran), _)), _), adamc@910: trans3) => adamc@910: let adamc@910: val e' = (EFfi ("Basis", "bind"), loc) adamc@910: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@910: val e' = (ECApp (e', dom), loc) adamc@910: val e' = (ECApp (e', t2), loc) adamc@910: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@910: val e' = (EApp (e', exp (UnknownE :: env') adamc@910: (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), adamc@910: loc) adamc@910: val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) adamc@910: val e' = reassoc e' adamc@910: val e' = (EAbs ("x", dom, t2, e'), loc) adamc@910: val e' = (EServerCall (n, es, e', dom, t2), loc) adamc@910: in adamc@910: e' adamc@910: end adamc@910: adamc@910: | EApp adamc@910: ((EApp adamc@910: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), adamc@910: _), _), _), t3), _), adamc@910: me), _), adamc@910: (EApp ((EApp adamc@910: ((EApp ((ECApp ((ECApp ((ECApp ( adamc@910: (EFfi ("Basis", "bind"), _), _), _), adamc@910: t1), _), t2), _), adamc@910: _), _), adamc@910: trans1), _), (EAbs (_, _, _, trans2), _)), _)), _), adamc@910: trans3) => adamc@910: let adamc@910: val e'' = (EFfi ("Basis", "bind"), loc) adamc@910: val e'' = (ECApp (e'', mt), loc) adamc@910: val e'' = (ECApp (e'', t2), loc) adamc@910: val e'' = (ECApp (e'', t3), loc) adamc@910: val e'' = (EApp (e'', me), loc) adamc@910: val e'' = (EApp (e'', trans2), loc) adamc@910: val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) adamc@910: val e'' = reassoc e'' adamc@910: val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) adamc@910: adamc@910: val e' = (EFfi ("Basis", "bind"), loc) adamc@910: val e' = (ECApp (e', mt), loc) adamc@910: val e' = (ECApp (e', t1), loc) adamc@910: val e' = (ECApp (e', t3), loc) adamc@910: val e' = (EApp (e', me), loc) adamc@910: val e' = (EApp (e', trans1), loc) adamc@910: val e' = (EApp (e', e''), loc) adamc@910: in adamc@910: e' adamc@910: end adamc@910: adamc@910: | EApp adamc@910: ((EApp adamc@910: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), adamc@910: _), _), _), t3), _), adamc@910: me), _), adamc@910: (EApp ((EApp adamc@910: ((EApp ((ECApp ((ECApp ((ECApp ( adamc@910: (EFfi ("Basis", "bind"), _), _), _), adamc@910: t1), _), t2), _), adamc@910: _), _), adamc@910: trans1), _), trans2), _)), _), adamc@910: trans3) => adamc@910: let adamc@910: val e'' = (EFfi ("Basis", "bind"), loc) adamc@910: val e'' = (ECApp (e'', mt), loc) adamc@910: val e'' = (ECApp (e'', t2), loc) adamc@910: val e'' = (ECApp (e'', t3), loc) adamc@910: val e'' = (EApp (e'', me), loc) adamc@910: val () = print "In2\n" adamc@910: val e'' = (EApp (e'', exp (UnknownE :: env') adamc@910: (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), adamc@910: loc)), adamc@910: loc) adamc@910: val () = print "Out2\n" adamc@910: val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) adamc@910: val e'' = reassoc e'' adamc@910: val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) adamc@910: adamc@910: val e' = (EFfi ("Basis", "bind"), loc) adamc@910: val e' = (ECApp (e', mt), loc) adamc@910: val e' = (ECApp (e', t1), loc) adamc@910: val e' = (ECApp (e', t3), loc) adamc@910: val e' = (EApp (e', me), loc) adamc@910: val e' = (EApp (e', trans1), loc) adamc@910: val e' = (EApp (e', e''), loc) adamc@910: in adamc@910: e' adamc@910: end adamc@910: adamc@931: | EApp adamc@931: ((EApp adamc@931: ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), adamc@931: t1), adamc@931: _), t2), _), adamc@931: (EFfi ("Basis", "transaction_monad"), _)), _), adamc@931: (ECase (e, pes, {disc, ...}), _)), _), trans) => adamc@931: let adamc@931: val e' = (EFfi ("Basis", "bind"), loc) adamc@931: val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) adamc@931: val e' = (ECApp (e', t1), loc) adamc@931: val e' = (ECApp (e', t2), loc) adamc@931: val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) adamc@931: adamc@931: fun doCase (p, e) = adamc@931: let adamc@931: val e' = (EApp (e', e), loc) adamc@931: val e' = (EApp (e', adamc@931: multiLiftExpInExp (E.patBindsN p) adamc@931: trans), loc) adamc@931: in adamc@931: (p, reassoc e') adamc@931: end adamc@931: in adamc@931: (ECase (e, map doCase pes, adamc@931: {disc = disc, adamc@931: result = (CApp ((CFfi ("Basis", "transaction"), loc), adamc@931: t2), loc)}), loc) adamc@931: end adamc@931: adamc@910: | _ => e adamc@910: adamc@909: val e1 = exp env e1 adamc@909: val e2 = exp env e2 adamc@910: val e12 = reassoc (EApp (e1, e2), loc) adamc@909: in adamc@910: case #1 e12 of adamc@910: EApp ((EAbs (_, _, _, b), _), e2) => adamc@931: exp (KnownE e2 :: env') b adamc@910: | _ => e12 adamc@909: end adamc@509: adamc@909: | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) adamc@509: adamc@909: | ECApp (e, c) => adamc@909: let adamc@909: val e = exp env e adamc@909: val c = con env c adamc@909: in adamc@909: case #1 e of adamc@909: ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b adamc@909: | _ => (ECApp (e, c), loc) adamc@909: end adamc@626: adamc@909: | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc) adamc@626: adamc@909: | EKApp (e, k) => adamc@909: let adamc@909: val e = exp env e adamc@909: in adamc@909: case #1 e of adamc@909: EKAbs (_, b) => exp (KnownK k :: deKnown env) b adamc@909: | _ => (EKApp (e, kind env k), loc) adamc@909: end adamc@509: adamc@909: | EKAbs (x, e) => (EKAbs (x, exp (UnknownK :: env) e), loc) adamc@509: adamc@909: | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) adamc@909: | EField (e, c, {field, rest}) => adamc@909: let adamc@909: val e = exp env e adamc@909: val c = con env c adamc@509: adamc@909: fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc) adamc@909: in adamc@909: case (#1 e, #1 c) of adamc@909: (ERecord xcs, CName x) => adamc@909: (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of adamc@909: NONE => default () adamc@909: | SOME (_, e, _) => e) adamc@909: | _ => default () adamc@909: end adamc@509: adamc@909: | EConcat (e1, c1, e2, c2) => adamc@909: let adamc@909: val e1 = exp env e1 adamc@909: val e2 = exp env e2 adamc@909: in adamc@909: case (#1 e1, #1 e2) of adamc@909: (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc) adamc@909: | _ => adamc@909: let adamc@909: val c1 = con env c1 adamc@909: val c2 = con env c2 adamc@909: in adamc@909: case (#1 c1, #1 c2) of adamc@909: (CRecord (k, xcs1), CRecord (_, xcs2)) => adamc@909: let adamc@909: val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1 adamc@909: val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2 adamc@909: in adamc@909: exp (deKnown env) (ERecord (xes1 @ xes2), loc) adamc@909: end adamc@909: | _ => (EConcat (e1, c1, e2, c2), loc) adamc@909: end adamc@909: end adamc@509: adamc@909: | ECut (e, c, {field, rest}) => adamc@909: let adamc@909: val e = exp env e adamc@909: val c = con env c adamc@509: adamc@909: fun default () = adamc@909: let adamc@909: val rest = con env rest adamc@909: in adamc@909: case #1 rest of adamc@909: CRecord (k, xcs) => adamc@909: let adamc@909: val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs adamc@909: in adamc@909: exp (deKnown env) (ERecord xes, loc) adamc@909: end adamc@909: | _ => (ECut (e, c, {field = con env field, rest = rest}), loc) adamc@909: end adamc@909: in adamc@909: case (#1 e, #1 c) of adamc@909: (ERecord xes, CName x) => adamc@909: if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then adamc@909: (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x adamc@909: | _ => raise Fail "Reduce: ECut") xes), loc) adamc@909: else adamc@909: default () adamc@909: | _ => default () adamc@909: end adamc@509: adamc@909: | ECutMulti (e, c, {rest}) => adamc@909: let adamc@909: val e = exp env e adamc@909: val c = con env c adamc@509: adamc@909: fun default () = adamc@909: let adamc@909: val rest = con env rest adamc@909: in adamc@909: case #1 rest of adamc@909: CRecord (k, xcs) => adamc@909: let adamc@909: val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs adamc@909: in adamc@909: exp (deKnown env) (ERecord xes, loc) adamc@909: end adamc@909: | _ => (ECutMulti (e, c, {rest = rest}), loc) adamc@909: end adamc@909: in adamc@909: case (#1 e, #1 c) of adamc@909: (ERecord xes, CRecord (_, xcs)) => adamc@909: if List.all (fn ((CName _, _), _, _) => true | _ => false) xes adamc@909: andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then adamc@909: (ERecord (List.filter (fn ((CName x', _), _, _) => adamc@909: List.all (fn ((CName x, _), _) => x' <> x adamc@909: | _ => raise Fail "Reduce: ECutMulti [1]") xcs adamc@909: | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc) adamc@909: else adamc@909: default () adamc@909: | _ => default () adamc@909: end adamc@823: adamc@909: | ECase (_, [((PRecord [], _), e)], _) => exp env e adamc@909: | ECase (_, [((PWild, _), e)], _) => exp env e adamc@509: adamc@909: | ECase (e, pes, {disc, result}) => adamc@909: let adamc@909: fun patBinds (p, _) = adamc@909: case p of adamc@909: PWild => 0 adamc@909: | PVar _ => 1 adamc@909: | PPrim _ => 0 adamc@909: | PCon (_, _, _, NONE) => 0 adamc@909: | PCon (_, _, _, SOME p) => patBinds p adamc@909: | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts adamc@509: adamc@909: fun pat (all as (p, loc)) = adamc@909: case p of adamc@909: PWild => all adamc@909: | PVar (x, t) => (PVar (x, con env t), loc) adamc@909: | PPrim _ => all adamc@909: | PCon (dk, pc, cs, po) => adamc@909: (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) adamc@909: | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) adamc@930: adamc@930: fun push () = adamc@930: (ECase (exp env e, adamc@930: map (fn (p, e) => (pat p, adamc@930: exp (List.tabulate (patBinds p, adamc@930: fn _ => UnknownE) @ env) e)) adamc@930: pes, {disc = con env disc, result = con env result}), loc) adamc@930: adamc@930: fun search pes = adamc@930: case pes of adamc@930: [] => push () adamc@930: | (p, body) :: pes => adamc@930: case match (env, p, e) of adamc@930: No => search pes adamc@930: | Maybe => push () adamc@930: | Yes env' => exp env' body adamc@909: in adamc@930: search pes adamc@909: end adamc@509: adamc@909: | EWrite e => (EWrite (exp env e), loc) adamc@909: | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) adamc@607: adamc@910: | ELet (x, t, e1, e2) => adamc@910: (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) adamc@909: adamc@909: | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, adamc@909: con env t1, con env t2), loc) adamc@909: in adamc@909: (*if dangling (edepth' (deKnown env)) r then adamc@909: (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), adamc@909: ("r", CorePrint.p_exp CoreEnv.empty r)]; adamc@909: raise Fail "!!") adamc@909: else adamc@909: ();*) adamc@909: r adamc@909: end adamc@417: in adamc@626: {kind = kind, con = con, exp = exp} adamc@417: end adamc@21: adamc@626: fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k adamc@626: fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c adamc@626: fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e adamc@20: adamc@508: fun reduce file = adamc@508: let adamc@508: fun doDecl (d as (_, loc), st as (namedC, namedE)) = adamc@508: case #1 d of adamc@508: DCon (x, n, k, c) => adamc@508: let adamc@626: val k = kind namedC [] k adamc@509: val c = con namedC [] c adamc@508: in adamc@508: ((DCon (x, n, k, c), loc), adamc@508: (IM.insert (namedC, n, c), namedE)) adamc@508: end adamc@807: | DDatatype dts => adamc@807: ((DDatatype (map (fn (x, n, ps, cs) => adamc@807: let adamc@807: val env = map (fn _ => UnknownC) ps adamc@807: in adamc@807: (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs) adamc@807: end) dts), loc), adamc@807: st) adamc@508: | DVal (x, n, t, e, s) => adamc@508: let adamc@509: val t = con namedC [] t adamc@509: val e = exp (namedC, namedE) [] e adamc@508: in adamc@508: ((DVal (x, n, t, e, s), loc), adamc@508: (namedC, IM.insert (namedE, n, e))) adamc@508: end adamc@508: | DValRec vis => adamc@910: ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, adamc@910: exp (namedC, namedE) [] e, s)) vis), loc), adamc@508: st) adamc@508: | DExport _ => (d, st) adamc@707: | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s', adamc@707: exp (namedC, namedE) [] pe, adamc@707: con namedC [] pc, adamc@707: exp (namedC, namedE) [] ce, adamc@707: con namedC [] cc), loc), st) adamc@508: | DSequence _ => (d, st) adamc@754: | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st) adamc@508: | DDatabase _ => (d, st) adamc@509: | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) adamc@720: | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) adamc@20: adamc@508: val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file adamc@508: in adamc@508: file adamc@508: end adamc@20: adamc@20: end