diff options
author | 2008-06-26 11:32:29 -0400 | |
---|---|---|
committer | 2008-06-26 11:32:29 -0400 | |
commit | 140f5079a41a0aae9ad3e577c96b443eb5337ca5 (patch) | |
tree | 40fb8cd3e4a8812fd9b9952edb403f9547a31c90 | |
parent | 84104b2ae60ef293b9d837998b8162d58e8d4a0e (diff) |
Corify efold
-rw-r--r-- | src/core.sml | 1 | ||||
-rw-r--r-- | src/core_print.sml | 1 | ||||
-rw-r--r-- | src/core_util.sml | 4 | ||||
-rw-r--r-- | src/corify.sml | 172 | ||||
-rw-r--r-- | src/monoize.sml | 1 | ||||
-rw-r--r-- | tests/efold.lac | 2 |
6 files changed, 125 insertions, 56 deletions
diff --git a/src/core.sml b/src/core.sml index 07ab4641..78f0cce0 100644 --- a/src/core.sml +++ b/src/core.sml @@ -69,6 +69,7 @@ datatype exp' = | ERecord of (con * exp * con) list | EField of exp * con * { field : con, rest : con } + | EFold of kind withtype exp = exp' located diff --git a/src/core_print.sml b/src/core_print.sml index 7242e720..b6e611f4 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -222,6 +222,7 @@ fun p_exp' par env (e, _) = box [p_exp' true env e, string ".", p_con' true env c] + | EFold _ => string "fold" and p_exp env = p_exp' false env diff --git a/src/core_util.sml b/src/core_util.sml index 66918863..8a174d9e 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -278,6 +278,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx rest, fn rest' => (EField (e', c', {field = field', rest = rest'}), loc))))) + | EFold k => + S.map2 (mfk k, + fn k' => + (EFold k', loc)) in mfe end diff --git a/src/corify.sml b/src/corify.sml index 893e0f2a..5dfd0db6 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -62,13 +62,19 @@ structure St : sig val leave : t -> {outer : t, inner : t} val ffi : string -> L'.con SM.map -> t - val bindCore : t -> string -> int -> t * int - val lookupCoreById : t -> int -> int option - - datatype core = - Normal of int - | Ffi of string * L'.con option - val lookupCoreByName : t -> string -> core + datatype core_con = + CNormal of int + | CFfi of string + val bindCon : t -> string -> int -> t * int + val lookupConById : t -> int -> int option + val lookupConByName : t -> string -> core_con + + datatype core_val = + ENormal of int + | EFfi of string * L'.con + val bindVal : t -> string -> int -> t * int + val lookupValById : t -> int -> int option + val lookupValByName : t -> string -> core_val val bindStr : t -> string -> int -> t -> t val lookupStrById : t -> int -> t @@ -80,13 +86,16 @@ structure St : sig end = struct datatype flattening = - FNormal of {core : int SM.map, + FNormal of {cons : int SM.map, + vals : int SM.map, strs : flattening SM.map, funs : (int * L.str) SM.map} - | FFfi of string * L'.con SM.map + | FFfi of {mod : string, + vals : L'.con SM.map} type t = { - core : int IM.map, + cons : int IM.map, + vals : int IM.map, strs : flattening IM.map, funs : (int * L.str) IM.map, current : flattening, @@ -94,30 +103,69 @@ type t = { } val empty = { - core = IM.empty, + cons = IM.empty, + vals = IM.empty, strs = IM.empty, funs = IM.empty, - current = FNormal { core = SM.empty, strs = SM.empty, funs = SM.empty }, + current = FNormal { cons = SM.empty, vals = SM.empty, strs = SM.empty, funs = SM.empty }, nested = [] } -datatype core = - Normal of int - | Ffi of string * L'.con option +datatype core_con = + CNormal of int + | CFfi of string + +datatype core_val = + ENormal of int + | EFfi of string * L'.con + +fun bindCon {cons, vals, strs, funs, current, nested} s n = + let + val n' = alloc () + + val current = + case current of + FFfi _ => raise Fail "Binding inside FFfi" + | FNormal {cons, vals, strs, funs} => + FNormal {cons = SM.insert (cons, s, n'), + vals = vals, + strs = strs, + funs = funs} + in + ({cons = IM.insert (cons, n, n'), + vals = vals, + strs = strs, + funs = funs, + current = current, + nested = nested}, + n') + end + +fun lookupConById ({cons, ...} : t) n = IM.find (cons, n) + +fun lookupConByName ({current, ...} : t) x = + case current of + FFfi {mod = m, ...} => CFfi m + | FNormal {cons, ...} => + case SM.find (cons, x) of + NONE => raise Fail "Corify.St.lookupConByName" + | SOME n => CNormal n -fun bindCore {core, strs, funs, current, nested} s n = +fun bindVal {cons, vals, strs, funs, current, nested} s n = let val n' = alloc () val current = case current of FFfi _ => raise Fail "Binding inside FFfi" - | FNormal {core, strs, funs} => - FNormal {core = SM.insert (core, s, n'), + | FNormal {cons, vals, strs, funs} => + FNormal {cons = cons, + vals = SM.insert (vals, s, n'), strs = strs, funs = funs} in - ({core = IM.insert (core, n, n'), + ({cons = cons, + vals = IM.insert (vals, n, n'), strs = strs, funs = funs, current = current, @@ -125,33 +173,40 @@ fun bindCore {core, strs, funs, current, nested} s n = n') end -fun lookupCoreById ({core, ...} : t) n = IM.find (core, n) +fun lookupValById ({vals, ...} : t) n = IM.find (vals, n) -fun lookupCoreByName ({current, ...} : t) x = +fun lookupValByName ({current, ...} : t) x = case current of - FFfi (m, cmap) => Ffi (m, SM.find (cmap, x)) - | FNormal {core, ...} => - case SM.find (core, x) of - NONE => raise Fail "Corify.St.lookupCoreByName" - | SOME n => Normal n - -fun enter {core, strs, funs, current, nested} = - {core = core, + FFfi {mod = m, vals, ...} => + (case SM.find (vals, x) of + NONE => raise Fail "Corify.St.lookupValByName: no type for FFI val" + | SOME t => EFfi (m, t)) + | FNormal {vals, ...} => + case SM.find (vals, x) of + NONE => raise Fail "Corify.St.lookupValByName" + | SOME n => ENormal n + +fun enter {cons, vals, strs, funs, current, nested} = + {cons = cons, + vals = vals, strs = strs, funs = funs, - current = FNormal {core = SM.empty, + current = FNormal {cons = SM.empty, + vals = SM.empty, strs = SM.empty, funs = SM.empty}, nested = current :: nested} -fun dummy f = {core = IM.empty, +fun dummy f = {cons = IM.empty, + vals = IM.empty, strs = IM.empty, funs = IM.empty, current = f, nested = []} -fun leave {core, strs, funs, current, nested = m1 :: rest} = - {outer = {core = core, +fun leave {cons, vals, strs, funs, current, nested = m1 :: rest} = + {outer = {cons = cons, + vals = vals, strs = strs, funs = funs, current = m1, @@ -159,16 +214,19 @@ fun leave {core, strs, funs, current, nested = m1 :: rest} = inner = dummy current} | leave _ = raise Fail "Corify.St.leave" -fun ffi m cmap = dummy (FFfi (m, cmap)) +fun ffi m vals = dummy (FFfi {mod = m, vals = vals}) -fun bindStr ({core, strs, funs, current = FNormal {core = mcore, strs = mstrs, funs = mfuns}, nested} : t) +fun bindStr ({cons, vals, strs, funs, + current = FNormal {cons = mcons, vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) x n ({current = f, ...} : t) = - {core = core, + {cons = cons, + vals = vals, strs = IM.insert (strs, n, f), funs = funs, - current = FNormal {core = mcore, - strs = SM.insert (mstrs, x, f), - funs = mfuns}, + current = FNormal {cons = mcons, + vals = mvals, + strs = SM.insert (mstrs, x, f), + funs = mfuns}, nested = nested} | bindStr _ _ _ _ = raise Fail "Corify.St.bindStr" @@ -183,12 +241,15 @@ fun lookupStrByName (m, {current = FNormal {strs, ...}, ...} : t) = | SOME f => dummy f) | lookupStrByName _ = raise Fail "Corify.St.lookupStrByName" -fun bindFunctor ({core, strs, funs, current = FNormal {core = mcore, strs = mstrs, funs = mfuns}, nested} : t) +fun bindFunctor ({cons, vals, strs, funs, + current = FNormal {cons = mcons, vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) x n na str = - {core = core, + {cons = cons, + vals = vals, strs = strs, funs = IM.insert (funs, n, (na, str)), - current = FNormal {core = mcore, + current = FNormal {cons = mcons, + vals = mvals, strs = mstrs, funs = SM.insert (mfuns, x, (na, str))}, nested = nested} @@ -223,7 +284,7 @@ fun corifyCon st (c, loc) = | L.CRel n => (L'.CRel n, loc) | L.CNamed n => - (case St.lookupCoreById st n of + (case St.lookupConById st n of NONE => (L'.CNamed n, loc) | SOME n => (L'.CNamed n, loc)) | L.CModProj (m, ms, x) => @@ -231,9 +292,9 @@ fun corifyCon st (c, loc) = val st = St.lookupStrById st m val st = foldl St.lookupStrByName st ms in - case St.lookupCoreByName st x of - St.Normal n => (L'.CNamed n, loc) - | St.Ffi (m, _) => (L'.CFfi (m, x), loc) + case St.lookupConByName st x of + St.CNormal n => (L'.CNamed n, loc) + | St.CFfi m => (L'.CFfi (m, x), loc) end | L.CApp (c1, c2) => (L'.CApp (corifyCon st c1, corifyCon st c2), loc) @@ -251,7 +312,7 @@ fun corifyExp st (e, loc) = L.EPrim p => (L'.EPrim p, loc) | L.ERel n => (L'.ERel n, loc) | L.ENamed n => - (case St.lookupCoreById st n of + (case St.lookupValById st n of NONE => (L'.ENamed n, loc) | SOME n => (L'.ENamed n, loc)) | L.EModProj (m, ms, x) => @@ -259,10 +320,9 @@ fun corifyExp st (e, loc) = val st = St.lookupStrById st m val st = foldl St.lookupStrByName st ms in - case St.lookupCoreByName st x of - St.Normal n => (L'.ENamed n, loc) - | St.Ffi (_, NONE) => raise Fail "corifyExp: Unknown type for FFI expression variable" - | St.Ffi (m, SOME t) => + case St.lookupValByName st x of + St.ENormal n => (L'.ENamed n, loc) + | St.EFfi (m, t) => case t of (L'.TFun (dom as (L'.TRecord (L'.CRecord (_, []), _), _), ran), _) => (L'.EAbs ("arg", dom, ran, (L'.EFfiApp (m, x, []), loc)), loc) @@ -299,19 +359,19 @@ fun corifyExp st (e, loc) = | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc) | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c, {field = corifyCon st field, rest = corifyCon st rest}), loc) - | L.EFold _ => raise Fail "Corify EFold" + | L.EFold k => (L'.EFold (corifyKind k), loc) fun corifyDecl ((d, loc : EM.span), st) = case d of L.DCon (x, n, k, c) => let - val (st, n) = St.bindCore st x n + val (st, n) = St.bindCon st x n in ([(L'.DCon (x, n, corifyKind k, corifyCon st c), loc)], st) end | L.DVal (x, n, t, e) => let - val (st, n) = St.bindCore st x n + val (st, n) = St.bindVal st x n in ([(L'.DVal (x, n, corifyCon st t, corifyExp st e), loc)], st) end @@ -338,7 +398,7 @@ fun corifyDecl ((d, loc : EM.span), st) = case sgi of L.SgiConAbs (x, n, k) => let - val (st, n') = St.bindCore st x n + val (st, n') = St.bindCon st x n in ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds, cmap, @@ -346,7 +406,7 @@ fun corifyDecl ((d, loc : EM.span), st) = end | L.SgiCon (x, n, k, _) => let - val (st, n') = St.bindCore st x n + val (st, n') = St.bindCon st x n in ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds, cmap, diff --git a/src/monoize.sml b/src/monoize.sml index f8a0d96e..16c128aa 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -97,6 +97,7 @@ fun monoExp env (all as (e, loc)) = | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc) | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc) + | L.EFold _ => poly () end fun monoDecl env (all as (d, loc)) = diff --git a/tests/efold.lac b/tests/efold.lac index 6f4c768c..ff595ff1 100644 --- a/tests/efold.lac +++ b/tests/efold.lac @@ -4,3 +4,5 @@ val currier : rs :: {Type} -> Cfold.currier rs = val greenCurry : Cfold.greenCurry = currier [Cfold.greenCurryIngredients] val redCurry : Cfold.redCurry = currier [Cfold.redCurryIngredients] val yellowCurry : Cfold.yellowCurry = currier [Cfold.yellowCurryIngredients] + +val main = yellowCurry |