adamc@26: (* Copyright (c) 2008, Adam Chlipala
adamc@26:  * All rights reserved.
adamc@26:  *
adamc@26:  * Redistribution and use in source and binary forms, with or without
adamc@26:  * modification, are permitted provided that the following conditions are met:
adamc@26:  *
adamc@26:  * - Redistributions of source code must retain the above copyright notice,
adamc@26:  *   this list of conditions and the following disclaimer.
adamc@26:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@26:  *   this list of conditions and the following disclaimer in the documentation
adamc@26:  *   and/or other materials provided with the distribution.
adamc@26:  * - The names of contributors may not be used to endorse or promote products
adamc@26:  *   derived from this software without specific prior written permission.
adamc@26:  *
adamc@26:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@26:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@26:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@26:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@26:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@26:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@26:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@26:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@26:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@26:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@26:  * POSSIBILITY OF SUCH DAMAGE.
adamc@26:  *)
adamc@26: 
adamc@26: structure Cloconv :> CLOCONV = struct
adamc@26: 
adamc@26: structure L = Mono
adamc@26: structure L' = Flat
adamc@26: 
adamc@26: structure IS = IntBinarySet
adamc@26: 
adamc@26: structure U = FlatUtil
adamc@26: structure E = FlatEnv
adamc@26: 
adamc@26: open Print.PD
adamc@26: open Print
adamc@26: 
adamc@26: val liftExpInExp =
adamc@26:     U.Exp.mapB {typ = fn t => t,
adamc@26:                 exp = fn bound => fn e =>
adamc@26:                                      case e of
adamc@26:                                          L'.ERel xn =>
adamc@26:                                          if xn < bound then
adamc@26:                                              e
adamc@26:                                          else
adamc@26:                                              L'.ERel (xn + 1)
adamc@26:                                        | _ => e,
adamc@26:                 bind = fn (bound, U.Exp.RelE _) => bound + 1
adamc@26:                         | (bound, _) => bound}
adamc@26: val subExpInExp =
adamc@26:     U.Exp.mapB {typ = fn t => t,
adamc@26:                 exp = fn (xn, rep) => fn e =>
adamc@26:                                   case e of
adamc@26:                                       L'.ERel xn' =>
adamc@74:                                       (case Int.compare (xn', xn) of
adamc@74:                                            EQUAL => #1 rep
adamc@74:                                          | GREATER => L'.ERel (xn' - 1)
adamc@74:                                          | _ => e)
adamc@26:                                     | _ => e,
adamc@26:                 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adamc@26:                         | (ctx, _) => ctx}
adamc@26: 
adamc@26: 
adamc@26: fun ccTyp (t, loc) =
adamc@26:     case t of
adamc@26:         L.TFun (t1, t2) => (L'.TFun (ccTyp t1, ccTyp t2), loc)
adamc@26:       | L.TRecord xts => (L'.TRecord (map (fn (x, t) => (x, ccTyp t)) xts), loc)
adamc@26:       | L.TNamed n => (L'.TNamed n, loc)
adamc@52:       | L.TFfi mx => (L'.TFfi mx, loc)
adamc@26: 
adamc@26: structure Ds :> sig
adamc@26:     type t
adamc@26: 
adamc@26:     val empty : t
adamc@26: 
adamc@26:     val exp : t -> string * int * L'.typ * L'.exp -> t
adamc@26:     val func : t -> string * L'.typ * L'.typ * L'.exp -> t * int
adamc@26:     val decls : t -> L'.decl list
adamc@26: 
adamc@26:     val enter : t -> t
adamc@26:     val used : t * int -> t
adamc@26:     val leave : t -> t
adamc@26:     val listUsed : t -> int list
adamc@26: end = struct
adamc@26: 
adamc@26: type t = int * L'.decl list * IS.set
adamc@26: 
adamc@26: val empty = (0, [], IS.empty)
adamc@26: 
adamc@26: fun exp (fc, ds, vm) (v as (_, _, _, (_, loc))) = (fc, (L'.DVal v, loc) :: ds, vm)
adamc@26: 
adamc@26: fun func (fc, ds, vm) (x, dom, ran, e as (_, loc)) =
adamc@26:     ((fc+1, (L'.DFun (fc, x, dom, ran, e), loc) :: ds, vm), fc)
adamc@26: 
adamc@26: fun decls (_, ds, _) = rev ds
adamc@26: 
adamc@26: fun enter (fc, ds, vm) = (fc, ds, IS.map (fn n => n + 1) vm)
adamc@26: fun used ((fc, ds, vm), n) = (fc, ds, IS.add (vm, n))
adamc@26: fun leave (fc, ds, vm) = (fc, ds, IS.map (fn n => n - 1) (IS.delete (vm, 0) handle NotFound => vm))
adamc@26: 
adamc@26: fun listUsed (_, _, vm) = IS.listItems vm
adamc@26: 
adamc@26: end
adamc@26: 
adamc@26: 
adamc@26: fun ccExp env ((e, loc), D) =
adamc@26:     case e of
adamc@26:         L.EPrim p => ((L'.EPrim p, loc), D)
adamc@26:       | L.ERel n => ((L'.ERel n, loc), Ds.used (D, n))
adamc@26:       | L.ENamed n => ((L'.ENamed n, loc), D)
adamc@52:       | L.EFfi mx => ((L'.EFfi mx, loc), D)
adamc@52:       | L.EFfiApp (m, x, es) =>
adamc@52:         let
adamc@52:             val (es, D) = ListUtil.foldlMap (ccExp env) D es
adamc@52:         in
adamc@52:             ((L'.EFfiApp (m, x, es), loc), D)
adamc@52:         end
adamc@26:       | L.EApp (e1, e2) =>
adamc@26:         let
adamc@26:             val (e1, D) = ccExp env (e1, D)
adamc@26:             val (e2, D) = ccExp env (e2, D)
adamc@26:         in
adamc@29:             ((L'.ELet ([("closure", (L'.TTop, loc), e1),
adamc@29:                         ("arg", (L'.TTop, loc), liftExpInExp 0 e2),
adamc@29:                         ("code", (L'.TTop, loc), (L'.EField ((L'.ERel 1, loc), "func"), loc)),
adamc@29:                         ("env", (L'.TTop, loc), (L'.EField ((L'.ERel 2, loc), "env"), loc))],
adamc@26:                        (L'.EApp ((L'.ERel 1, loc),
adamc@29:                                  (L'.ERecord [("env", (L'.ERel 0, loc), (L'.TTop, loc)),
adamc@29:                                               ("arg", (L'.ERel 2, loc), (L'.TTop, loc))], loc)), loc)), loc), D)
adamc@26:         end
adamc@26:       | L.EAbs (x, dom, ran, e) =>
adamc@26:         let
adamc@26:             val dom = ccTyp dom
adamc@26:             val ran = ccTyp ran
adamc@26:             val (e, D) = ccExp (E.pushERel env x dom) (e, Ds.enter D)
adamc@26:             val ns = Ds.listUsed D
adamc@26:             val ns = List.filter (fn n => n <> 0) ns
adamc@26:             val D = Ds.leave D
adamc@26: 
adamc@26:             (*val () = Print.preface ("Before", FlatPrint.p_exp FlatEnv.basis e)
adamc@26:             val () = List.app (fn (x, t) => preface ("Bound", box [string x,
adamc@26:                                                                    space,
adamc@26:                                                                    string ":",
adamc@26:                                                                    space,
adamc@26:                                                                    FlatPrint.p_typ env t]))
adamc@26:                      (E.listERels env)
adamc@26:             val () = List.app (fn n => preface ("Free", FlatPrint.p_exp (E.pushERel env x dom)
adamc@26:                                                         (L'.ERel n, loc))) ns*)
adamc@26:             val body = foldl (fn (n, e) =>
adamc@26:                                  subExpInExp (n, (L'.EField ((L'.ERel 1, loc), "fv" ^ Int.toString n), loc)) e)
adamc@26:                              e ns
adamc@26:             (*val () = Print.preface (" After", FlatPrint.p_exp FlatEnv.basis body)*)
adamc@29:             val body = (L'.ELet ([("env", (L'.TTop, loc), (L'.EField ((L'.ERel 0, loc), "env"), loc)),
adamc@29:                                   ("arg", (L'.TTop, loc), (L'.EField ((L'.ERel 1, loc), "arg"), loc))],
adamc@26:                                  body), loc)
adamc@26:                               
adamc@26:             val envT = (L'.TRecord (map (fn n => ("fv" ^ Int.toString n, #2 (E.lookupERel env (n-1)))) ns), loc)
adamc@26:             val (D, fi) = Ds.func D (x, (L'.TRecord [("env", envT), ("arg", dom)], loc), ran, body)
adamc@26:         in
adamc@29:             ((L'.ERecord [("code", (L'.ECode fi, loc), (L'.TTop, loc)),
adamc@26:                           ("env", (L'.ERecord (map (fn n => ("fv" ^ Int.toString n,
adamc@29:                                                              (L'.ERel (n-1), loc),
adamc@29:                                                              #2 (E.lookupERel env (n-1)))) ns), loc),
adamc@29:                            envT)], loc), D)
adamc@26:         end
adamc@26: 
adamc@26:       | L.ERecord xes =>
adamc@26:         let
adamc@29:             val (xes, D) = ListUtil.foldlMap (fn ((x, e, t), D) =>
adamc@26:                                                  let
adamc@26:                                                      val (e, D) = ccExp env (e, D)
adamc@26:                                                  in
adamc@29:                                                      ((x, e, ccTyp t), D)
adamc@26:                                                  end) D xes
adamc@26:         in
adamc@26:             ((L'.ERecord xes, loc), D)
adamc@26:         end
adamc@26:       | L.EField (e1, x) =>
adamc@26:         let
adamc@26:             val (e1, D) = ccExp env (e1, D)
adamc@26:         in
adamc@26:             ((L'.EField (e1, x), loc), D)
adamc@26:         end
adamc@26: 
adamc@26: fun ccDecl ((d, loc), D) =
adamc@26:     case d of
adamc@26:         L.DVal (x, n, t, e) =>
adamc@26:         let
adamc@26:             val t = ccTyp t
adamc@56:             val (e, D) = ccExp E.empty (e, D)
adamc@26:         in
adamc@26:             Ds.exp D (x, n, t, e)
adamc@26:         end
adamc@26: 
adamc@26: fun cloconv ds =
adamc@26:     let
adamc@26:         val D = foldl ccDecl Ds.empty ds
adamc@26:     in
adamc@26:         Ds.decls D
adamc@26:     end
adamc@26: 
adamc@26: end