adamc@607: (* Copyright (c) 2009, Adam Chlipala
adamc@607:  * All rights reserved.
adamc@607:  *
adamc@607:  * Redistribution and use in source and binary forms, with or without
adamc@607:  * modification, are permitted provided that the following conditions are met:
adamc@607:  *
adamc@607:  * - Redistributions of source code must retain the above copyright notice,
adamc@607:  *   this list of conditions and the following disclaimer.
adamc@607:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@607:  *   this list of conditions and the following disclaimer in the documentation
adamc@607:  *   and/or other materials provided with the distribution.
adamc@607:  * - The names of contributors may not be used to endorse or promote products
adamc@607:  *   derived from this software without specific prior written permission.
adamc@607:  *
adamc@607:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@607:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@607:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@607:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@607:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@607:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@607:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@607:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@607:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@607:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@607:  * POSSIBILITY OF SUCH DAMAGE.
adamc@607:  *)
adamc@607: 
adamc@607: structure Rpcify :> RPCIFY = struct
adamc@607: 
adamc@607: open Core
adamc@607: 
adamc@607: structure U = CoreUtil
adamc@607: structure E = CoreEnv
adamc@607: 
adamc@607: structure IS = IntBinarySet
adamc@607: structure IM = IntBinaryMap
adamc@607: 
adamc@607: structure SS = BinarySetFn(struct
adamc@607:                            type ord_key = string
adamc@607:                            val compare = String.compare
adamc@607:                            end)
adamc@607: 
adamc@642: fun multiLiftExpInExp n e =
adamc@642:     if n = 0 then
adamc@642:         e
adamc@642:     else
adamc@642:         multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
adamc@642: 
adamc@607: val ssBasis = SS.addList (SS.empty,
adamc@607:                           ["requestHeader",
adamc@607:                            "query",
adamc@607:                            "dml",
adamc@607:                            "nextval"])
adamc@607: 
adamc@607: val csBasis = SS.addList (SS.empty,
adamc@607:                           ["source",
adamc@607:                            "get",
adamc@607:                            "set",
adamc@607:                            "alert"])
adamc@607: 
adamc@607: type state = {
adamc@608:      cpsed : int IM.map,
adamc@642:      cpsed_range : con IM.map,
adamc@608:      cps_decls : (string * int * con * exp * string) list,
adamc@608: 
adamc@608:      exported : IS.set,
adamc@642:      export_decls : decl list,
adamc@642: 
adamc@642:      maxName : int
adamc@607: }
adamc@607: 
adamc@607: fun frob file =
adamc@607:     let
adamc@607:         fun sideish (basis, ssids) =
adamc@607:             U.Exp.exists {kind = fn _ => false,
adamc@607:                           con = fn _ => false,
adamc@607:                           exp = fn ENamed n => IS.member (ssids, n)
adamc@607:                                  | EFfi ("Basis", x) => SS.member (basis, x)
adamc@607:                                  | EFfiApp ("Basis", x, _) => SS.member (basis, x)
adamc@607:                                  | _ => false}
adamc@607: 
adamc@607:         fun whichIds basis =
adamc@607:             let
adamc@607:                 fun decl ((d, _), ssids) =
adamc@607:                     let
adamc@607:                         val impure = sideish (basis, ssids)
adamc@607:                     in
adamc@607:                         case d of
adamc@607:                             DVal (_, n, _, e, _) => if impure e then
adamc@607:                                                         IS.add (ssids, n)
adamc@607:                                                     else
adamc@607:                                                         ssids
adamc@607:                           | DValRec xes => if List.exists (fn (_, _, _, e, _) => impure e) xes then
adamc@607:                                                foldl (fn ((_, n, _, _, _), ssids) => IS.add (ssids, n))
adamc@607:                                                      ssids xes
adamc@607:                                            else
adamc@607:                                                ssids
adamc@607:                           | _ => ssids
adamc@607:                     end
adamc@607:             in
adamc@607:                 foldl decl IS.empty file
adamc@607:             end
adamc@607: 
adamc@607:         val ssids = whichIds ssBasis
adamc@607:         val csids = whichIds csBasis
adamc@607: 
adamc@642:         fun sideish' (basis, ids) extra =
adamc@642:             sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra)
adamc@642: 
adamc@642:         val serverSide = sideish' (ssBasis, ssids)
adamc@642:         val clientSide = sideish' (csBasis, csids)
adamc@607: 
adamc@609:         val tfuncs = foldl
adamc@609:                      (fn ((d, _), tfuncs) =>
adamc@609:                          let
adamc@642:                              fun doOne ((x, n, t, e, _), tfuncs) =
adamc@609:                                  let
adamc@642:                                      val loc = #2 e
adamc@642: 
adamc@642:                                      fun crawl (t, e, args) =
adamc@642:                                          case (#1 t, #1 e) of
adamc@642:                                              (CApp (_, ran), _) =>
adamc@642:                                              SOME (x, rev args, ran, e)
adamc@642:                                            | (TFun (arg, rest), EAbs (x, _, _, e)) =>
adamc@642:                                              crawl (rest, e, (x, arg) :: args)
adamc@642:                                            | (TFun (arg, rest), _) =>
adamc@642:                                              crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args)
adamc@609:                                            | _ => NONE
adamc@609:                                  in
adamc@642:                                      case crawl (t, e, []) of
adamc@609:                                          NONE => tfuncs
adamc@609:                                        | SOME sg => IM.insert (tfuncs, n, sg)
adamc@609:                                  end
adamc@609:                          in
adamc@609:                              case d of
adamc@609:                                  DVal vi => doOne (vi, tfuncs)
adamc@609:                                | DValRec vis => foldl doOne tfuncs vis
adamc@609:                                | _ => tfuncs
adamc@609:                          end)
adamc@609:                      IM.empty file
adamc@609:                              
adamc@607:         fun exp (e, st) =
adamc@607:             case e of
adamc@607:                 EApp (
adamc@607:                 (EApp
adamc@607:                      ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
adamc@607:                              (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@642:                       (ECase (ed, pes, {disc, ...}), _)), _),
adamc@607:                 trans2) =>
adamc@642:                 let
adamc@642:                     val e' = (EFfi ("Basis", "bind"), loc)
adamc@642:                     val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@642:                     val e' = (ECApp (e', t1), loc)
adamc@642:                     val e' = (ECApp (e', t2), loc)
adamc@642:                     val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@607: 
adamc@642:                     val (pes, st) = ListUtil.foldlMap (fn ((p, e), st) =>
adamc@642:                                                           let
adamc@642:                                                               val e' = (EApp (e', e), loc)
adamc@642:                                                               val e' = (EApp (e',
adamc@642:                                                                               multiLiftExpInExp (E.patBindsN p)
adamc@642:                                                                                                 trans2), loc)
adamc@642:                                                               val (e', st) = doExp (e', st)
adamc@642:                                                           in
adamc@642:                                                               ((p, e'), st)
adamc@642:                                                           end) st pes
adamc@642:                 in
adamc@642:                     (ECase (ed, pes, {disc = disc,
adamc@642:                                       result = (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc)}),
adamc@642:                      st)
adamc@642:                 end
adamc@608: 
adamc@642:               | EApp (
adamc@642:                 (EApp
adamc@642:                      ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
adamc@642:                              (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@642:                       (EServerCall (n, es, ke, t), _)), _),
adamc@642:                 trans2) =>
adamc@642:                 let
adamc@642:                     val e' = (EFfi ("Basis", "bind"), loc)
adamc@642:                     val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@642:                     val e' = (ECApp (e', t), loc)
adamc@642:                     val e' = (ECApp (e', t2), loc)
adamc@642:                     val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@642:                     val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
adamc@642:                     val e' = (EApp (e', E.liftExpInExp 0 trans2), loc)
adamc@642:                     val e' = (EAbs ("x", t, t2, e'), loc)
adamc@642:                     val e' = (EServerCall (n, es, e', t), loc)
adamc@642:                     val (e', st) = doExp (e', st)
adamc@642:                 in
adamc@642:                     (#1 e', st)
adamc@642:                 end
adamc@608: 
adamc@642:               | EApp (
adamc@642:                 (EApp
adamc@642:                      ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), _), _), t3), _),
adamc@642:                              (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@642:                       (EApp ((EApp
adamc@642:                                   ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
adamc@642:                                           (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@642:                                    trans1), _), trans2), _)), _),
adamc@642:                 trans3) =>
adamc@642:                 let
adamc@642:                     val e'' = (EFfi ("Basis", "bind"), loc)
adamc@642:                     val e'' = (ECApp (e'', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@642:                     val e'' = (ECApp (e'', t2), loc)
adamc@642:                     val e'' = (ECApp (e'', t3), loc)
adamc@642:                     val e'' = (EApp (e'', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@642:                     val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc)
adamc@642:                     val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc)
adamc@642:                     val e'' = (EAbs ("x", t1, (CApp ((CFfi ("Basis", "transaction"), loc), t3), loc), e''), loc)
adamc@608: 
adamc@642:                     val e' = (EFfi ("Basis", "bind"), loc)
adamc@642:                     val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@642:                     val e' = (ECApp (e', t1), loc)
adamc@642:                     val e' = (ECApp (e', t3), loc)
adamc@642:                     val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@642:                     val e' = (EApp (e', trans1), loc)
adamc@642:                     val e' = (EApp (e', e''), loc)
adamc@642:                     val (e', st) = doExp (e', st)
adamc@642:                 in
adamc@642:                     (#1 e', st)
adamc@642:                 end
adamc@609: 
adamc@642:               | EApp (
adamc@642:                 (EApp
adamc@642:                      ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), _), _), _), _),
adamc@642:                              (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@642:                       _), loc),
adamc@642:                 (EAbs (_, _, _, (EWrite _, _)), _)) => (e, st)
adamc@642: 
adamc@642:               | EApp (
adamc@642:                 (EApp
adamc@642:                      ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
adamc@642:                              (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@642:                       trans1), loc),
adamc@642:                 trans2) =>
adamc@642:                 let
adamc@642:                     (*val () = Print.prefaces "Default"
adamc@642:                                             [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*)
adamc@642: 
adamc@642:                     fun getApp (e', args) =
adamc@642:                         case #1 e' of
adamc@642:                             ENamed n => (n, args)
adamc@642:                           | EApp (e1, e2) => getApp (e1, e2 :: args)
adamc@642:                           | _ => (ErrorMsg.errorAt loc "Mixed client/server code doesn't use a named function for server part";
adamc@642:                                   Print.prefaces "Bad" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];
adamc@642:                                   (0, []))
adamc@642:                 in
adamc@642:                     case (serverSide (#cpsed_range st) trans1, clientSide (#cpsed_range st) trans1,
adamc@642:                           serverSide (#cpsed_range st) trans2, clientSide (#cpsed_range st) trans2) of
adamc@642:                         (true, false, _, true) =>
adamc@642:                         let
adamc@642:                             val (n, args) = getApp (trans1, [])
adamc@642: 
adamc@642:                             val (exported, export_decls) =
adamc@642:                                 if IS.member (#exported st, n) then
adamc@642:                                     (#exported st, #export_decls st)
adamc@642:                                 else
adamc@642:                                     (IS.add (#exported st, n),
adamc@642:                                      (DExport (Rpc, n), loc) :: #export_decls st)
adamc@642: 
adamc@642:                             val st = {cpsed = #cpsed st,
adamc@642:                                       cpsed_range = #cpsed_range st,
adamc@642:                                       cps_decls = #cps_decls st,
adamc@642: 
adamc@642:                                       exported = exported,
adamc@642:                                       export_decls = export_decls,
adamc@642: 
adamc@642:                                       maxName = #maxName st}
adamc@642: 
adamc@642:                             val ran =
adamc@642:                                 case IM.find (tfuncs, n) of
adamc@642:                                     NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];
adamc@642:                                              raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
adamc@642:                                   | SOME (_, _, ran, _) => ran
adamc@642: 
adamc@642:                             val e' = EServerCall (n, args, trans2, ran)
adamc@642:                         in
adamc@642:                             (EServerCall (n, args, trans2, ran), st)
adamc@642:                         end
adamc@642:                       | (true, true, _, _) =>
adamc@642:                         let
adamc@642:                             val (n, args) = getApp (trans1, [])
adamc@642: 
adamc@642:                             fun makeCall n' =
adamc@642:                                 let
adamc@642:                                     val e = (ENamed n', loc)
adamc@642:                                     val e = (EApp (e, trans2), loc)
adamc@642:                                 in
adamc@642:                                     #1 (foldl (fn (arg, e) => (EApp (e, arg), loc)) e args)
adamc@642:                                 end
adamc@642:                         in
adamc@642:                             case IM.find (#cpsed_range st, n) of
adamc@642:                                 SOME kdom =>
adamc@642:                                 (case args of
adamc@642:                                      [] => raise Fail "Rpcify: cps'd function lacks first argument"
adamc@642:                                    | ke :: args =>
adamc@642:                                      let
adamc@642:                                          val ke' = (EFfi ("Basis", "bind"), loc)
adamc@642:                                          val ke' = (ECApp (ke', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@642:                                          val ke' = (ECApp (ke', kdom), loc)
adamc@642:                                          val ke' = (ECApp (ke', t2), loc)
adamc@642:                                          val ke' = (EApp (ke', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@642:                                          val ke' = (EApp (ke', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc)
adamc@642:                                          val ke' = (EApp (ke', E.liftExpInExp 0 trans2), loc)
adamc@642:                                          val ke' = (EAbs ("x", kdom,
adamc@642:                                                           (CApp ((CFfi ("Basis", "transaction"), loc), t2), loc),
adamc@642:                                                           ke'), loc)
adamc@642: 
adamc@642:                                          val e' = (ENamed n, loc)
adamc@642:                                          val e' = (EApp (e', ke'), loc)
adamc@642:                                          val e' = foldl (fn (arg, e') => (EApp (e', arg), loc)) e' args
adamc@642:                                          val (e', st) = doExp (e', st)
adamc@642:                                      in
adamc@642:                                          (#1 e', st)
adamc@642:                                      end)
adamc@642:                               | NONE =>
adamc@642:                                 case IM.find (#cpsed st, n) of
adamc@642:                                     SOME n' => (makeCall n', st)
adamc@642:                                   | NONE =>
adamc@642:                                     let
adamc@642:                                         val (name, fargs, ran, e) =
adamc@642:                                             case IM.find (tfuncs, n) of
adamc@642:                                                 NONE => (Print.prefaces "BAD" [("e",
adamc@642:                                                                                 CorePrint.p_exp CoreEnv.empty (e, loc))];
adamc@642:                                                          raise Fail "Rpcify: Undetected transaction function [2]")
adamc@642:                                               | SOME x => x
adamc@642: 
adamc@642:                                         val n' = #maxName st
adamc@642: 
adamc@642:                                         val st = {cpsed = IM.insert (#cpsed st, n, n'),
adamc@642:                                                   cpsed_range = IM.insert (#cpsed_range st, n', ran),
adamc@642:                                                   cps_decls = #cps_decls st,
adamc@642:                                                   exported = #exported st,
adamc@642:                                                   export_decls = #export_decls st,
adamc@642:                                                   maxName = n' + 1}
adamc@642: 
adamc@642:                                         val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@642:                                         val body = (EFfi ("Basis", "bind"), loc)
adamc@642:                                         val body = (ECApp (body, (CFfi ("Basis", "transaction"), loc)), loc)
adamc@642:                                         val body = (ECApp (body, t1), loc)
adamc@642:                                         val body = (ECApp (body, unit), loc)
adamc@642:                                         val body = (EApp (body, (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@642:                                         val body = (EApp (body, e), loc)
adamc@642:                                         val body = (EApp (body, (ERel (length args), loc)), loc)
adamc@642:                                         val bt = (CApp ((CFfi ("Basis", "transaction"), loc), unit), loc)
adamc@642:                                         val (body, bt) = foldr (fn ((x, t), (body, bt)) =>
adamc@642:                                                                    ((EAbs (x, t, bt, body), loc),
adamc@642:                                                                     (TFun (t, bt), loc)))
adamc@642:                                                                (body, bt) fargs
adamc@642:                                         val kt = (TFun (ran, (CApp ((CFfi ("Basis", "transaction"), loc),
adamc@642:                                                                     unit),
adamc@642:                                                               loc)), loc)
adamc@642:                                         val body = (EAbs ("k", kt, bt, body), loc)
adamc@642:                                         val bt = (TFun (kt, bt), loc)
adamc@642: 
adamc@642:                                         val (body, st) = doExp (body, st)
adamc@642: 
adamc@642:                                         val vi = (name ^ "_cps",
adamc@642:                                                   n',
adamc@642:                                                   bt,
adamc@642:                                                   body,
adamc@642:                                                   "")
adamc@642: 
adamc@642:                                         val st = {cpsed = #cpsed st,
adamc@642:                                                   cpsed_range = #cpsed_range st,
adamc@642:                                                   cps_decls = vi :: #cps_decls st,
adamc@642:                                                   exported = #exported st,
adamc@642:                                                   export_decls = #export_decls st,
adamc@642:                                                   maxName = #maxName st}
adamc@642:                                     in
adamc@642:                                         (makeCall n', st)
adamc@642:                                     end
adamc@642:                         end
adamc@642:                       | _ => (e, st)
adamc@642:                 end
adamc@607:               | _ => (e, st)
adamc@607: 
adamc@642:         and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
adamc@642:                                            con = fn x => x,
adamc@642:                                            exp = exp} st (ReduceLocal.reduceExp e)
adamc@642: 
adamc@607:         fun decl (d, st : state) =
adamc@607:             let
adamc@607:                 val (d, st) = U.Decl.foldMap {kind = fn x => x,
adamc@607:                                               con = fn x => x,
adamc@607:                                               exp = exp,
adamc@607:                                               decl = fn x => x}
adamc@607:                               st d
adamc@607:             in
adamc@608:                 (List.revAppend (case #cps_decls st of
adamc@608:                                      [] => [d]
adamc@608:                                    | ds =>
adamc@608:                                      case d of
adamc@608:                                          (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
adamc@608:                                        | (_, loc) => [d, (DValRec ds, loc)],
adamc@608:                                  #export_decls st),
adamc@608:                  {cpsed = #cpsed st,
adamc@642:                   cpsed_range = #cpsed_range st,
adamc@608:                   cps_decls = [],
adamc@608:                   
adamc@608:                   exported = #exported st,
adamc@642:                   export_decls = [],
adamc@642: 
adamc@642:                   maxName = #maxName st})
adamc@607:             end
adamc@607: 
adamc@607:         val (file, _) = ListUtil.foldlMapConcat decl
adamc@608:                         {cpsed = IM.empty,
adamc@642:                          cpsed_range = IM.empty,
adamc@608:                          cps_decls = [],
adamc@608: 
adamc@608:                          exported = IS.empty,
adamc@642:                          export_decls = [],
adamc@642: 
adamc@642:                          maxName = U.File.maxName file + 1}
adamc@607:                         file
adamc@607:     in
adamc@607:         file
adamc@607:     end
adamc@607: 
adamc@607: end