Mercurial > urweb

annotate src/reduce.sml @ 464:91914c15a85b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Cookie demo code; fix error message display
author Adam Chlipala <adamc@hcoop.net>
date Thu, 06 Nov 2008 12:22:50 -0500
parents dfc8c991abd0
children ae03d09043c1
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@193 38 val subConInCon = E.subConInCon
adamc@417 39 val liftConInExp = E.liftConInExp
adamc@443 40 val liftExpInExp = E.liftExpInExp
adamc@443 41 val subExpInExp = E.subExpInExp
adamc@315 42 val liftConInExp = E.liftConInExp
adamc@315 43 val subConInExp = E.subConInExp
adamc@21 44
adamc@20 45 fun bindC (env, b) =
adamc@20 46 case b of
adamc@20 47 U.Con.Rel (x, k) => E.pushCRel env x k
adamc@20 48 | U.Con.Named (x, n, k, co) => E.pushCNamed env x n k co
adamc@20 49
adamc@20 50 fun bind (env, b) =
adamc@20 51 case b of
adamc@20 52 U.Decl.RelC (x, k) => E.pushCRel env x k
adamc@20 53 | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
adamc@20 54 | U.Decl.RelE (x, t) => E.pushERel env x t
adamc@109 55 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
adamc@20 56
adamc@20 57 fun kind k = k
adamc@20 58
adamc@20 59 fun con env c =
adamc@20 60 case c of
adamc@70 61 CApp ((CApp ((CApp ((CFold ks, _), f), _), i), loc), (CRecord (k, xcs), _)) =>
adamc@70 62 (case xcs of
adamc@70 63 [] => #1 i
adamc@70 64 | (n, v) :: rest =>
adamc@70 65 #1 (reduceCon env (CApp ((CApp ((CApp (f, n), loc), v), loc),
adamc@70 66 (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc),
adamc@70 67 (CRecord (k, rest), loc)), loc)), loc)))
adamc@70 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@215 75
adamc@215 76 | CProj ((CTuple cs, _), n) => #1 (List.nth (cs, n - 1))
adamc@215 77
adamc@20 78 | _ => c
adamc@20 79
adamc@20 80 and reduceCon env = U.Con.mapB {kind = kind, con = con, bind = bindC} env
adamc@20 81
adamc@21 82 fun exp env e =
adamc@417 83 let
adamc@417 84 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@21 85
adamc@417 86 val r = case e of
adamc@417 87 ENamed n =>
adamc@417 88 (case E.lookupENamed env n of
adamc@417 89 (_, _, SOME e', _) => #1 e'
adamc@417 90 | _ => e)
adamc@74 91
adamc@417 92 | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) =>
adamc@417 93 (case xcs of
adamc@417 94 [] => #1 i
adamc@417 95 | (n, v) :: rest =>
adamc@417 96 #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc),
adamc@417 97 (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc),
adamc@417 98 (CRecord (k, rest), loc)), loc)), loc)))
adamc@21 99
adamc@417 100 | EApp ((EAbs (_, _, _, e1), loc), e2) =>
adamc@417 101 #1 (reduceExp env (subExpInExp (0, e2) e1))
adamc@417 102 | ECApp ((ECAbs (_, _, e1), loc), c) =>
adamc@417 103 #1 (reduceExp env (subConInExp (0, c) e1))
adamc@22 104
adamc@417 105 | EField ((ERecord xes, _), (CName x, _), _) =>
adamc@417 106 (case List.find (fn ((CName x', _), _, _) => x' = x
adamc@417 107 | _ => false) xes of
adamc@417 108 SOME (_, e, _) => #1 e
adamc@417 109 | NONE => e)
adamc@445 110 | EConcat (r1 as (_, loc), (CRecord (k, xts1), _), r2, (CRecord (_, xts2), _)) =>
adamc@417 111 let
adamc@445 112 fun fields (r, remaining, passed) =
adamc@417 113 case remaining of
adamc@417 114 [] => []
adamc@417 115 | (x, t) :: rest =>
adamc@417 116 (x,
adamc@417 117 (EField (r, x, {field = t,
adamc@417 118 rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc),
adamc@445 119 t) :: fields (r, rest, (x, t) :: passed)
adamc@417 120 in
adamc@445 121 #1 (reduceExp env (ERecord (fields (r1, xts1, []) @ fields (r2, xts2, [])), loc))
adamc@417 122 end
adamc@417 123 | ECut (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) =>
adamc@417 124 let
adamc@417 125 fun fields (remaining, passed) =
adamc@417 126 case remaining of
adamc@417 127 [] => []
adamc@417 128 | (x, t) :: rest =>
adamc@417 129 (x,
adamc@417 130 (EField (r, x, {field = t,
adamc@417 131 rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc),
adamc@417 132 t) :: fields (rest, (x, t) :: passed)
adamc@417 133 in
adamc@417 134 #1 (reduceExp env (ERecord (fields (xts, [])), loc))
adamc@417 135 end
adamc@417 136
adamc@417 137 | _ => e
adamc@417 138 in
adamc@417 139 (*Print.prefaces "exp'" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@417 140 ("r", CorePrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@417 141
adamc@417 142 r
adamc@417 143 end
adamc@21 144
adamc@21 145 and reduceExp env = U.Exp.mapB {kind = kind, con = con, exp = exp, bind = bind} env
adamc@20 146
adamc@330 147 fun decl env d =
adamc@330 148 case d of
adamc@330 149 DValRec [vi as (_, n, _, e, _)] =>
adamc@330 150 let
adamc@330 151 fun kind _ = false
adamc@330 152 fun con _ = false
adamc@330 153 fun exp e =
adamc@330 154 case e of
adamc@330 155 ENamed n' => n' = n
adamc@330 156 | _ => false
adamc@330 157 in
adamc@330 158 if U.Exp.exists {kind = kind, con = con, exp = exp} e then
adamc@330 159 d
adamc@330 160 else
adamc@330 161 DVal vi
adamc@330 162 end
adamc@330 163 | _ => d
adamc@20 164
adamc@133 165 val reduce = U.File.mapB {kind = kind, con = con, exp = exp, decl = decl, bind = bind} E.empty
adamc@20 166
adamc@20 167 end