adamc@484: (* Copyright (c) 2008, Adam Chlipala
adamc@484:  * All rights reserved.
adamc@484:  *
adamc@484:  * Redistribution and use in source and binary forms, with or without
adamc@484:  * modification, are permitted provided that the following conditions are met:
adamc@484:  *
adamc@484:  * - Redistributions of source code must retain the above copyright notice,
adamc@484:  *   this list of conditions and the following disclaimer.
adamc@484:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@484:  *   this list of conditions and the following disclaimer in the documentation
adamc@484:  *   and/or other materials provided with the distribution.
adamc@484:  * - The names of contributors may not be used to endorse or promote products
adamc@484:  *   derived from this software without specific prior written permission.
adamc@484:  *
adamc@484:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@484:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@484:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@484:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@484:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@484:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@484:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@484:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@484:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@484:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@484:  * POSSIBILITY OF SUCH DAMAGE.
adamc@484:  *)
adamc@484: 
adamc@484: structure Defunc :> DEFUNC = struct
adamc@484: 
adamc@484: open Core
adamc@484: 
adamc@484: structure E = CoreEnv
adamc@484: structure U = CoreUtil
adamc@484: 
adamc@484: structure IS = IntBinarySet
adamc@484: 
adamc@484: val functionInside = U.Con.exists {kind = fn _ => false,
adamc@484:                                    con = fn TFun _ => true
adamc@484:                                           | CFfi ("Basis", "transaction") => true
adamc@484:                                           | _ => false}
adamc@484: 
adamc@626: val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs,
adamc@484:                             con = fn (_, _, xs) => xs,
adamc@484:                             exp = fn (bound, e, xs) =>
adamc@484:                                      case e of
adamc@484:                                          ERel x =>
adamc@484:                                          if x >= bound then
adamc@484:                                              IS.add (xs, x - bound)
adamc@484:                                          else
adamc@484:                                              xs
adamc@484:                                        | _ => xs,
adamc@484:                             bind = fn (bound, b) =>
adamc@484:                                       case b of
adamc@484:                                           U.Exp.RelE _ => bound + 1
adamc@484:                                         | _ => bound}
adamc@484:                            0 IS.empty
adamc@484: 
adamc@484: fun positionOf (v : int, ls) =
adamc@484:     let
adamc@484:         fun pof (pos, ls) =
adamc@484:             case ls of
adamc@484:                 [] => raise Fail "Defunc.positionOf"
adamc@484:               | v' :: ls' =>
adamc@484:                 if v = v' then
adamc@484:                     pos
adamc@484:                 else
adamc@484:                     pof (pos + 1, ls')
adamc@484:     in
adamc@484:         pof (0, ls)
adamc@484:     end
adamc@484: 
adamc@484: fun squish fvs =
adamc@626:     U.Exp.mapB {kind = fn _ => fn k => k,
adamc@484:                 con = fn _ => fn c => c,
adamc@484:                 exp = fn bound => fn e =>
adamc@484:                                      case e of
adamc@484:                                          ERel x =>
adamc@484:                                          if x >= bound then
adamc@484:                                              ERel (positionOf (x - bound, fvs) + bound)
adamc@484:                                          else
adamc@484:                                              e
adamc@484:                                        | _ => e,
adamc@484:                 bind = fn (bound, b) =>
adamc@484:                           case b of
adamc@484:                               U.Exp.RelE _ => bound + 1
adamc@484:                             | _ => bound}
adamc@484:                0
adamc@484: 
adamc@484: fun default (_, x, st) = (x, st)
adamc@484: 
adamc@484: datatype 'a search =
adamc@484:          Yes
adamc@484:        | No
adamc@484:        | Maybe of 'a
adamc@484: 
adamc@484: structure EK = struct
adamc@484: type ord_key = exp
adamc@484: val compare = U.Exp.compare
adamc@484: end
adamc@484: 
adamc@484: structure EM = BinaryMapFn(EK)
adamc@484: 
adamc@484: type state = {
adamc@484:      maxName : int,
adamc@484:      funcs : int EM.map,
adamc@484:      vis : (string * int * con * exp * string) list
adamc@484: }
adamc@484: 
adamc@484: fun exp (env, e, st) =
adamc@484:     case e of
adamc@484:         ERecord xes =>
adamc@484:         let
adamc@484:             val (xes, st) =
adamc@484:                 ListUtil.foldlMap
adamc@484:                     (fn (tup as (fnam as (CName x, loc), e, xt), st) =>
adamc@485:                          if (x <> "Link" andalso x <> "Action")
adamc@485:                             orelse case #1 e of
adamc@485:                                        ENamed _ => true
adamc@485:                                      | _ => false then
adamc@484:                              (tup, st)
adamc@484:                          else
adamc@484:                              let
adamc@484:                                  fun needsAttention (e, _) =
adamc@484:                                      case e of
adamc@484:                                          ENamed f => Maybe (#2 (E.lookupENamed env f))
adamc@484:                                        | EApp (f, _) =>
adamc@484:                                          (case needsAttention f of
adamc@484:                                               No => No
adamc@484:                                             | Yes => Yes
adamc@484:                                             | Maybe t =>
adamc@484:                                               case t of
adamc@484:                                                   (TFun (dom, _), _) =>
adamc@484:                                                   if functionInside dom then
adamc@484:                                                       Yes
adamc@484:                                                   else
adamc@484:                                                       No
adamc@484:                                                 | _ => No)
adamc@484:                                        | _ => No
adamc@484: 
adamc@484:                                  fun headSymbol (e, _) =
adamc@484:                                      case e of
adamc@484:                                          ENamed f => f
adamc@484:                                        | EApp (e, _) => headSymbol e
adamc@484:                                        | _ => raise Fail "Defunc: headSymbol"
adamc@484: 
adamc@484:                                  fun rtype (e, _) =
adamc@484:                                      case e of
adamc@484:                                          ENamed f => #2 (E.lookupENamed env f)
adamc@484:                                        | EApp (f, _) =>
adamc@484:                                          (case rtype f of
adamc@484:                                               (TFun (_, ran), _) => ran
adamc@484:                                             | _ => raise Fail "Defunc: rtype [1]")
adamc@484:                                        | _ => raise Fail "Defunc: rtype [2]"
adamc@484:                              in
adamc@484:                                  (*Print.prefaces "Found one!"
adamc@484:                                                 [("e", CorePrint.p_exp env e)];*)
adamc@484:                                  case needsAttention e of
adamc@484:                                      Yes =>
adamc@484:                                      let
adamc@484:                                          (*val () = print "Yes\n"*)
adamc@484:                                          val f = headSymbol e
adamc@484: 
adamc@484:                                          val fvs = IS.listItems (freeVars e)
adamc@484: 
adamc@484:                                          val e = squish fvs e
adamc@484:                                          val (e, t) = foldl (fn (n, (e, t)) =>
adamc@484:                                                                 let
adamc@484:                                                                     val (x, xt) = E.lookupERel env n
adamc@484:                                                                 in
adamc@484:                                                                     ((EAbs (x, xt, t, e), loc),
adamc@484:                                                                      (TFun (xt, t), loc))
adamc@484:                                                                 end)
adamc@484:                                                             (e, rtype e) fvs
adamc@484: 
adamc@484:                                          val (f', st) =
adamc@484:                                              case EM.find (#funcs st, e) of
adamc@484:                                                  SOME f' => (f', st)
adamc@484:                                                | NONE =>
adamc@484:                                                  let
adamc@484:                                                      val (fx, _, _, tag) = E.lookupENamed env f
adamc@484:                                                      val f' = #maxName st
adamc@484: 
adamc@484:                                                      val vi = (fx, f', t, e, tag)
adamc@484:                                                  in
adamc@484:                                                      (f', {maxName = f' + 1,
adamc@484:                                                            funcs = EM.insert (#funcs st, e, f'),
adamc@484:                                                            vis = vi :: #vis st})
adamc@484:                                                  end
adamc@484: 
adamc@484:                                          val e = foldr (fn (n, e) =>
adamc@484:                                                            (EApp (e, (ERel n, loc)), loc))
adamc@484:                                                        (ENamed f', loc) fvs
adamc@484:                                      in
adamc@484:                                          (*app (fn n => Print.prefaces
adamc@484:                                                             "Free"
adamc@484:                                                             [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))])
adamc@484:                                                fvs;
adamc@484:                                           Print.prefaces "Squished"
adamc@484:                                                          [("e", CorePrint.p_exp CoreEnv.empty e)];*)
adamc@484: 
adamc@484:                                          ((fnam, e, xt), st)
adamc@484:                                      end
adamc@484:                                    | _ => (tup, st)
adamc@484:                              end
adamc@484:                       | (tup, st) => (tup, st))
adamc@484:                 st xes
adamc@484:         in
adamc@484:             (ERecord xes, st)
adamc@484:         end
adamc@484:       | _ => (e, st)
adamc@484: 
adamc@484: fun bind (env, b) =
adamc@484:     case b of
adamc@626:         U.Decl.RelK x => E.pushKRel env x
adamc@626:       | U.Decl.RelC (x, k) => E.pushCRel env x k
adamc@484:       | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co
adamc@484:       | U.Decl.RelE (x, t) => E.pushERel env x t
adamc@484:       | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
adamc@484: 
adamc@626: fun doDecl env = U.Decl.foldMapB {kind = default,
adamc@484:                                   con = default,
adamc@484:                                   exp = exp,
adamc@484:                                   decl = default,
adamc@484:                                   bind = bind}
adamc@484:                                  env
adamc@484: 
adamc@484: fun defunc file =
adamc@484:     let
adamc@484:         fun doDecl' (d, (env, st)) =
adamc@484:             let
adamc@484:                 val env = E.declBinds env d
adamc@484: 
adamc@484:                 val (d, st) = doDecl env st d
adamc@484: 
adamc@484:                 val ds =
adamc@484:                     case #vis st of
adamc@484:                         [] => [d]
adamc@484:                       | vis =>
adamc@484:                         case d of
adamc@484:                             (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)]
adamc@484:                           | _ => [(DValRec vis, #2 d), d]
adamc@484:             in
adamc@484:                 (ds,
adamc@484:                  (env,
adamc@484:                   {maxName = #maxName st,
adamc@484:                    funcs = #funcs st,
adamc@484:                    vis = []}))
adamc@484:             end
adamc@484: 
adamc@484:         val (file, _) = ListUtil.foldlMapConcat doDecl'
adamc@484:                         (E.empty,
adamc@484:                          {maxName = U.File.maxName file + 1,
adamc@484:                           funcs = EM.empty,
adamc@484:                           vis = []})
adamc@484:                         file
adamc@484:     in
adamc@484:         file
adamc@484:     end
adamc@484: 
adamc@484: end