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@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@21:                         | (ctx, _) => ctx}
adamc@21: 
adamc@21: val liftConInExp =
adamc@21:     U.Exp.mapB {kind = fn k => k,
adamc@21:                 con = fn bound => fn c =>
adamc@21:                                      case c of
adamc@21:                                          CRel xn =>
adamc@21:                                          if xn < bound then
adamc@21:                                              c
adamc@21:                                          else
adamc@21:                                              CRel (xn + 1)
adamc@21:                                        | _ => c,
adamc@21:                 exp = fn _ => fn e => e,
adamc@21:                 bind = fn (bound, U.Exp.RelC _) => bound + 1
adamc@21:                         | (bound, _) => bound}
adamc@21: 
adamc@21: val subConInExp =
adamc@21:     U.Exp.mapB {kind = fn k => k,
adamc@21:                 con = fn (xn, rep) => fn c =>
adamc@21:                                   case c of
adamc@21:                                       CRel xn' =>
adamc@74:                                       (case Int.compare (xn', xn) of
adamc@74:                                            EQUAL => #1 rep
adamc@74:                                          | GREATER => CRel (xn' - 1)
adamc@74:                                          | LESS => c)
adamc@21:                                     | _ => c,
adamc@21:                 exp = fn _ => fn e => e,
adamc@21:                 bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep)
adamc@21:                         | (ctx, _) => ctx}
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@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@21:     case e of
adamc@21:         ENamed n =>
adamc@21:         (case E.lookupENamed env n of
adamc@109:              (_, _, SOME e', _) => #1 e'
adamc@21:            | _ => e)
adamc@21: 
adamc@74:       | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) =>
adamc@74:         (case xcs of
adamc@74:              [] => #1 i
adamc@74:            | (n, v) :: rest =>
adamc@74:              #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc),
adamc@74:                                       (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc),
adamc@74:                                               (CRecord (k, rest), loc)), loc)), loc)))
adamc@74: 
adamc@26:       | EApp ((EAbs (_, _, _, e1), loc), e2) =>
adamc@21:         #1 (reduceExp env (subExpInExp (0, e2) e1))
adamc@21:       | ECApp ((ECAbs (_, _, e1), loc), c) =>
adamc@21:         #1 (reduceExp env (subConInExp (0, c) e1))
adamc@21: 
adamc@22:       | EField ((ERecord xes, _), (CName x, _), _) =>
adamc@29:         (case List.find (fn ((CName x', _), _, _) => x' = x
adamc@22:                           | _ => false) xes of
adamc@29:              SOME (_, e, _) => #1 e
adamc@22:            | NONE => e)
adamc@149:       | ECut (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) =>
adamc@149:         let
adamc@149:             fun fields (remaining, passed) =
adamc@149:                 case remaining of
adamc@149:                     [] => []
adamc@149:                   | (x, t) :: rest =>
adamc@149:                     (x,
adamc@149:                      (EField (r, x, {field = t,
adamc@149:                                      rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc),
adamc@149:                      t) :: fields (rest, (x, t) :: passed)
adamc@149:         in
adamc@149:             #1 (reduceExp env (ERecord (fields (xts, [])), loc))
adamc@149:         end
adamc@22: 
adamc@21:       | _ => e
adamc@21: 
adamc@21: and reduceExp env = U.Exp.mapB {kind = kind, con = con, exp = exp, bind = bind} env
adamc@20: 
adamc@20: fun decl env d = 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