adamc@879: (* Copyright (c) 2009, Adam Chlipala
adamc@879:  * All rights reserved.
adamc@879:  *
adamc@879:  * Redistribution and use in source and binary forms, with or without
adamc@879:  * modification, are permitted provided that the following conditions are met:
adamc@879:  *
adamc@879:  * - Redistributions of source code must retain the above copyright notice,
adamc@879:  *   this list of conditions and the following disclaimer.
adamc@879:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@879:  *   this list of conditions and the following disclaimer in the documentation
adamc@879:  *   and/or other materials provided with the distribution.
adamc@879:  * - The names of contributors may not be used to endorse or promote products
adamc@879:  *   derived from this software without specific prior written permission.
adamc@879:  *
adamc@879:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@879:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@879:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@879:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@879:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@879:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@879:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@879:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@879:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@879:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@879:  * POSSIBILITY OF SUCH DAMAGE.
adamc@879:  *)
adamc@879: 
adamc@879: structure Checknest :> CHECKNEST = struct
adamc@879: 
adamc@879: open Cjr
adamc@879: 
adamc@879: structure IS = IntBinarySet
adamc@879: structure IM = IntBinaryMap
adamc@879: 
adamc@879: fun expUses globals =
adamc@879:     let
adamc@879:         fun eu (e, _) =
adamc@879:             case e of
adamc@879:                 EPrim _ => IS.empty
adamc@879:               | ERel _ => IS.empty
adamc@879:               | ENamed n => Option.getOpt (IM.find (globals, n), IS.empty)
adamc@879:               | ECon (_, _, NONE) => IS.empty
adamc@879:               | ECon (_, _, SOME e) => eu e
adamc@879:               | ENone _ => IS.empty
adamc@879:               | ESome (_, e) => eu e
adamc@879:               | EFfi _ => IS.empty
adam@1663:               | EFfiApp (_, _, es) => foldl IS.union IS.empty (map (eu o #1) es)
adamc@879:               | EApp (e, es) => foldl IS.union (eu e) (map eu es)
adamc@879: 
adamc@879:               | EUnop (_, e) => eu e
adamc@879:               | EBinop (_, e1, e2) => IS.union (eu e1, eu e2)
adamc@879: 
adamc@879:               | ERecord (_, xes) => foldl (fn ((_, e), s) => IS.union (eu e, s)) IS.empty xes
adamc@879:               | EField (e, _) => eu e
adamc@879: 
adamc@879:               | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
adamc@879: 
adamc@879:               | EError (e, _) => eu e
adam@1932:               | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType
adam@1932:               | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
adamc@1065:               | ERedirect (e, _) => eu e
adamc@879: 
adamc@879:               | EWrite e => eu e
adamc@879:               | ESeq (e1, e2) => IS.union (eu e1, eu e2)
adamc@879:               | ELet (_, _, e1, e2) => IS.union (eu e1, eu e2)
adamc@879: 
adamc@879:               | EQuery {query, body, initial, prepared, ...} =>
adamc@879:                 let
adamc@879:                     val s = IS.union (eu query, IS.union (eu body, eu initial))
adamc@879:                 in
adamc@879:                     case prepared of
adamc@879:                         SOME {id, ...} => IS.add (s, id)
adamc@879:                       | _ => s
adamc@879:                 end
adamc@879:               | EDml {dml, prepared, ...} =>
adamc@879:                 let
adamc@879:                     val s = eu dml
adamc@879:                 in
adamc@879:                     case prepared of
adamc@879:                         SOME {id, ...} => IS.add (s, id)
adamc@879:                       | _ => s
adamc@879:                 end
adamc@879:               | ENextval {seq, prepared, ...} =>
adamc@879:                 let
adamc@879:                     val s = eu seq
adamc@879:                 in
adamc@879:                     case prepared of
adamc@879:                         SOME {id, ...} => IS.add (s, id)
adamc@879:                       | _ => s
adamc@879:                 end
adamc@1073:               | ESetval {seq, count} => IS.union (eu seq, eu count)
adamc@879: 
adamc@1112:               | EUnurlify (e, _, _) => eu e
adamc@879:     in
adamc@879:         eu
adamc@879:     end
adamc@879: 
adamc@879: fun annotateExp globals =
adamc@879:     let
adamc@879:         fun ae (e as (_, loc)) =
adamc@879:             case #1 e of
adamc@879:                 EPrim _ => e
adamc@879:               | ERel _ => e
adamc@879:               | ENamed n => e
adamc@879:               | ECon (_, _, NONE) => e
adamc@879:               | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (ae e)), loc)
adamc@879:               | ENone _ => e
adamc@879:               | ESome (t, e) => (ESome (t, ae e), loc)
adamc@879:               | EFfi _ => e
adam@1663:               | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (ae e, t)) es), loc)
adamc@879:               | EApp (e, es) => (EApp (ae e, map ae es), loc)
adamc@879: 
adamc@879:               | EUnop (uo, e) => (EUnop (uo, ae e), loc)
adamc@879:               | EBinop (bo, e1, e2) => (EBinop (bo, ae e1, ae e2), loc)
adamc@879: 
adamc@879:               | ERecord (n, xes) => (ERecord (n, map (fn (x, e) => (x, ae e)) xes), loc)
adamc@879:               | EField (e, f) => (EField (ae e, f), loc)
adamc@879: 
adamc@879:               | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
adamc@879: 
adamc@879:               | EError (e, t) => (EError (ae e, t), loc)
adam@1932:               | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc)
adam@1932:               | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc)
adamc@1065:               | ERedirect (e, t) => (ERedirect (ae e, t), loc)
adamc@879: 
adamc@879:               | EWrite e => (EWrite (ae e), loc)
adamc@879:               | ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc)
adamc@879:               | ELet (x, t, e1, e2) => (ELet (x, t, ae e1, ae e2), loc)
adamc@879: 
adamc@879:               | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
adamc@879:                 (EQuery {exps = exps,
adamc@879:                          tables = tables,
adamc@879:                          rnum = rnum,
adamc@879:                          state = state,
adamc@879:                          query = ae query,
adamc@879:                          body = ae body,
adamc@879:                          initial = ae initial,
adamc@879:                          prepared = case prepared of
adamc@879:                                         NONE => NONE
adamc@879:                                       | SOME {id, query, ...} => SOME {id = id, query = query,
adamc@879:                                                                        nested = IS.member (expUses globals body, id)}},
adamc@879:                  loc)
adam@1293:               | EDml {dml, prepared, mode} =>
adamc@879:                 (EDml {dml = ae dml,
adam@1293:                        prepared = prepared,
adam@1293:                        mode = mode}, loc)
adamc@879: 
adamc@879:               | ENextval {seq, prepared} =>
adamc@879:                 (ENextval {seq = ae seq,
adamc@879:                            prepared = prepared}, loc)
adamc@1073:               | ESetval {seq, count} =>
adamc@1073:                 (ESetval {seq = ae seq,
adamc@1073:                           count = ae count}, loc)
adamc@879: 
adamc@1112:               | EUnurlify (e, t, b) => (EUnurlify (ae e, t, b), loc)
adamc@879:     in
adamc@879:         ae
adamc@879:     end
adamc@879: 
adamc@879: fun annotate (ds, syms) =
adamc@879:     let
adamc@879:         val globals =
adamc@879:             foldl (fn ((d, _), globals) =>
adamc@879:                       case d of
adamc@879:                           DVal (_, n, _, e) => IM.insert (globals, n, expUses globals e)
adamc@879:                         | DFun (_, n, _, _, e) => IM.insert (globals, n, expUses globals e)
adamc@879:                         | DFunRec fs =>
adamc@879:                           let
adamc@879:                               val s = foldl (fn ((_, _, _, _, e), s) => IS.union (expUses globals e, s)) IS.empty fs
adamc@879:                           in
adamc@879:                               foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, s)) globals fs
adamc@879:                           end
adamc@879:                         | _ => globals) IM.empty ds
adamc@879: 
adamc@879:         val ds =
adamc@879:             map (fn d as (_, loc) =>
adamc@879:                     case #1 d of
adamc@879:                         DVal (x, n, t, e) => (DVal (x, n, t, annotateExp globals e), loc)
adamc@879:                       | DFun (x, n, ts, t, e) => (DFun (x, n, ts, t, annotateExp globals e), loc)
adamc@879:                       | DFunRec fs => (DFunRec
adamc@879:                                            (map (fn (x, n, ts, t, e) => (x, n, ts, t, annotateExp globals e)) fs), loc)
adamc@879:                       | _ => d) ds
adamc@879:     in
adamc@879:         (ds, syms)
adamc@879:     end
adamc@879: 
adamc@879: end