adamc@482: (* Copyright (c) 2008, Adam Chlipala
adamc@482:  * All rights reserved.
adamc@482:  *
adamc@482:  * Redistribution and use in source and binary forms, with or without
adamc@482:  * modification, are permitted provided that the following conditions are met:
adamc@482:  *
adamc@482:  * - Redistributions of source code must retain the above copyright notice,
adamc@482:  *   this list of conditions and the following disclaimer.
adamc@482:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@482:  *   this list of conditions and the following disclaimer in the documentation
adamc@482:  *   and/or other materials provided with the distribution.
adamc@482:  * - The names of contributors may not be used to endorse or promote products
adamc@482:  *   derived from this software without specific prior written permission.
adamc@482:  *
adamc@482:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@482:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@482:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@482:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@482:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@482:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@482:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@482:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@482:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@482:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@482:  * POSSIBILITY OF SUCH DAMAGE.
adamc@482:  *)
adamc@482: 
adamc@482: (* Simplify a Core program algebraically, without unfolding definitions *)
adamc@482: 
adamc@482: structure ReduceLocal :> REDUCE_LOCAL = struct
adamc@482: 
adamc@482: open Core
adamc@482: 
adamc@512: structure IM = IntBinaryMap
adamc@482: 
adamc@1062: fun multiLiftExpInExp n e =
adamc@1062:     if n = 0 then
adamc@1062:         e
adamc@1062:     else
adamc@1062:         multiLiftExpInExp (n - 1) (CoreEnv.liftExpInExp 0 e)
adamc@1062: 
adamc@512: datatype env_item =
adamc@512:          Unknown
adamc@512:        | Known of exp
adamc@482: 
adamc@512:        | Lift of int
adamc@482: 
adamc@512: type env = env_item list
adamc@512: 
adamc@512: val deKnown = List.filter (fn Known _ => false
adamc@512:                             | _ => true)
adamc@512: 
adamc@1062: datatype result = Yes of env | No | Maybe
adamc@1062: 
adamc@1062: fun match (env, p : pat, e : exp) =
adamc@1062:     let
adamc@1062:         val baseline = length env
adamc@1062: 
adamc@1062:         fun match (env, p, e) =
adamc@1062:             case (#1 p, #1 e) of
adamc@1062:                 (PWild, _) => Yes env
adamc@1062:               | (PVar (x, t), _) => Yes (Known (multiLiftExpInExp (length env - baseline) e) :: env)
adamc@1062: 
adamc@1062:               | (PPrim p, EPrim p') =>
adamc@1062:                 if Prim.equal (p, p') then
adamc@1062:                     Yes env
adamc@1062:                 else
adamc@1062:                     No
adamc@1062: 
adamc@1062:               | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
adamc@1062:                 if n1 = n2 then
adamc@1062:                     Yes env
adamc@1062:                 else
adamc@1062:                     No
adamc@1062: 
adamc@1062:               | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
adamc@1062:                 if n1 = n2 then
adamc@1062:                     match (env, p, e)
adamc@1062:                 else
adamc@1062:                     No
adamc@1062: 
adamc@1062:               | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
adamc@1062:                  ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
adamc@1062:                 if m1 = m2 andalso con1 = con2 then
adamc@1062:                     Yes env
adamc@1062:                 else
adamc@1062:                     No
adamc@1062: 
adamc@1062:               | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
adamc@1062:                  ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
adamc@1062:                 if m1 = m2 andalso con1 = con2 then
adamc@1062:                     match (env, p, e)
adamc@1062:                 else
adamc@1062:                     No
adamc@1062: 
adamc@1062:               | (PRecord xps, ERecord xes) =>
adamc@1062:                 if List.exists (fn ((CName _, _), _, _) => false
adamc@1062:                                  | _ => true) xes then
adamc@1062:                     Maybe
adamc@1062:                 else
adamc@1062:                     let
adamc@1062:                         fun consider (xps, env) =
adamc@1062:                             case xps of
adamc@1062:                                 [] => Yes env
adamc@1062:                               | (x, p, _) :: rest =>
adamc@1062:                                 case List.find (fn ((CName x', _), _, _) => x' = x
adamc@1062:                                                  | _ => false) xes of
adamc@1062:                                     NONE => No
adamc@1062:                                   | SOME (_, e, _) =>
adamc@1062:                                     case match (env, p, e) of
adamc@1062:                                         No => No
adamc@1062:                                       | Maybe => Maybe
adamc@1062:                                       | Yes env => consider (rest, env)
adamc@1062:                     in
adamc@1062:                         consider (xps, env)
adamc@1062:                     end
adamc@1062: 
adamc@1062:               | _ => Maybe
adamc@1062:     in
adamc@1062:         match (env, p, e)
adamc@1062:     end
adamc@1062: 
adamc@512: fun exp env (all as (e, loc)) =
adamc@512:     case e of
adamc@512:         EPrim _ => all
adamc@512:       | ERel n =>
adamc@512:         let
adamc@512:             fun find (n', env, nudge, lift) =
adamc@512:                 case env of
adamc@642:                     [] => (ERel (n + nudge), loc)
adamc@512:                   | Lift lift' :: rest => find (n', rest, nudge + lift', lift + lift')
adamc@512:                   | Unknown :: rest =>
adamc@512:                     if n' = 0 then
adamc@512:                         (ERel (n + nudge), loc)
adamc@512:                     else
adamc@512:                         find (n' - 1, rest, nudge, lift + 1)
adamc@512:                   | Known e :: rest =>
adamc@512:                     if n' = 0 then
adamc@512:                         ((*print "SUBSTITUTING\n";*)
adamc@512:                          exp (Lift lift :: rest) e)
adamc@512:                     else
adamc@512:                         find (n' - 1, rest, nudge - 1, lift)
adamc@512:         in
adamc@512:             find (n, env, 0, 0)
adamc@512:         end
adamc@512:       | ENamed _ => all
adamc@512:       | ECon (dk, pc, cs, eo) => (ECon (dk, pc, cs, Option.map (exp env) eo), loc)
adamc@512:       | EFfi _ => all
adamc@512:       | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
adamc@512: 
adamc@721:       | EApp ((ECApp ((ECAbs (_, _, (EAbs (_, (CRel 0, _), _,
adamc@721:                                            (ECon (dk, pc, [(CRel 0, loc)], SOME (ERel 0, _)), _)), _)), _),
adamc@721:                       t), _), e) =>
adamc@721:         (ECon (dk, pc, [t], SOME (exp env e)), loc)
adamc@721: 
adamc@512:       | EApp (e1, e2) =>
adamc@512:         let
adamc@512:             val e1 = exp env e1
adamc@512:             val e2 = exp env e2
adamc@512:         in
adamc@512:             case #1 e1 of
adamc@512:                 EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b
adamc@512:               | _ => (EApp (e1, e2), loc)
adamc@512:         end
adamc@512: 
adamc@512:       | EAbs (x, dom, ran, e) => (EAbs (x, dom, ran, exp (Unknown :: env) e), loc)
adamc@512: 
adamc@721:       | ECApp ((ECAbs (_, _, (ECon (dk, pc, [(CRel 0, loc)], NONE), _)), _), t) =>
adamc@721:         (ECon (dk, pc, [t], NONE), loc)
adamc@721: 
adamc@512:       | ECApp (e, c) => (ECApp (exp env e, c), loc)
adamc@626:       | ECAbs (x, k, e) => (ECAbs (x, k, exp env e), loc)
adamc@512: 
adamc@626:       | EKApp (e, k) => (EKApp (exp env e, k), loc)
adamc@626:       | EKAbs (x, e) => (EKAbs (x, exp env e), loc)
adamc@512: 
adamc@512:       | ERecord xcs => (ERecord (map (fn (x, e, t) => (x, exp env e, t)) xcs), loc)
adamc@512:       | EField (e, c, others) =>
adamc@512:         let
adamc@512:             val e = exp env e
adamc@512: 
adamc@512:             fun default () = (EField (e, c, others), loc)
adamc@512:         in
adamc@512:             case (#1 e, #1 c) of
adamc@512:                 (ERecord xcs, CName x) =>
adamc@512:                 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
adamc@512:                      NONE => default ()
adamc@512:                    | SOME (_, e, _) => e)
adamc@512:               | _ => default ()
adamc@512:         end
adamc@512: 
adamc@512:       | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, c1, exp env e2, c2), loc)
adamc@512:       | ECut (e, c, others) => (ECut (exp env e, c, others), loc)
adamc@512:       | ECutMulti (e, c, others) => (ECutMulti (exp env e, c, others), loc)
adamc@512: 
adamc@512:       | ECase (e, pes, others) =>
adamc@512:         let
adamc@512:             fun patBinds (p, _) =
adamc@512:                 case p of
adamc@512:                     PWild => 0
adamc@512:                   | PVar _ => 1
adamc@512:                   | PPrim _ => 0
adamc@512:                   | PCon (_, _, _, NONE) => 0
adamc@512:                   | PCon (_, _, _, SOME p) => patBinds p
adamc@512:                   | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@1062: 
adamc@1062:             fun push () =
adamc@1062:                 (ECase (exp env e,
adamc@1062:                         map (fn (p, e) => (p,
adamc@1062:                                            exp (List.tabulate (patBinds p,
adamc@1062:                                                             fn _ => Unknown) @ env) e))
adamc@1062:                             pes, others), loc)
adamc@1062: 
adamc@1062:             fun search pes =
adamc@1062:                 case pes of
adamc@1062:                     [] => push ()
adamc@1062:                   | (p, body) :: pes =>
adamc@1062:                     case match (env, p, e) of
adamc@1062:                         No => search pes
adamc@1062:                       | Maybe => push ()
adamc@1062:                       | Yes env' => exp env' body
adamc@512:         in
adamc@1062:             search pes
adamc@512:         end
adamc@512: 
adamc@512:       | EWrite e => (EWrite (exp env e), loc)
adamc@512:       | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
adamc@512: 
adamc@512:       | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc)
adamc@512: 
adamc@1020:       | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, t), loc)
adamc@607: 
adamc@512: fun reduce file =
adamc@482:     let
adamc@512:         fun doDecl (d as (_, loc)) =
adamc@512:             case #1 d of
adamc@512:                 DCon _ => d
adamc@512:               | DDatatype _ => d
adamc@512:               | DVal (x, n, t, e, s) =>
adamc@512:                 let
adamc@512:                     val e = exp [] e
adamc@512:                 in
adamc@512:                     (DVal (x, n, t, e, s), loc)
adamc@512:                 end
adamc@512:               | DValRec vis =>
adamc@512:                 (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc)
adamc@512:               | DExport _ => d
adamc@512:               | DTable _ => d
adamc@512:               | DSequence _ => d
adamc@754:               | DView _ => d
adamc@512:               | DDatabase _ => d
adamc@512:               | DCookie _ => d
adamc@718:               | DStyle _ => d
adamc@482:     in
adamc@512:         map doDecl file
adamc@482:     end
adamc@482: 
adamc@642: val reduceExp = exp []
adamc@642: 
adamc@482: end