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@94: | L.EStrcat _ => raise Fail "Cloconv EStrcat" adamc@94: 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