# HG changeset patch # User Adam Chlipala # Date 1217360597 14400 # Node ID 25b169416ea805d9a16bb2b41f0fcd7ff7a596c2 # Parent 2be573fec9a65f3240b58a577979627fc9704aa7 Storing datatype constructors in type references past monoize diff -r 2be573fec9a6 -r 25b169416ea8 src/cjr.sml --- a/src/cjr.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/cjr.sml Tue Jul 29 15:43:17 2008 -0400 @@ -33,7 +33,7 @@ TTop | TFun of typ * typ | TRecord of int - | TDatatype of int + | TDatatype of int * (string * int * typ option) list | TFfi of string * string withtype typ = typ' located diff -r 2be573fec9a6 -r 25b169416ea8 src/cjr_env.sml --- a/src/cjr_env.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/cjr_env.sml Tue Jul 29 15:43:17 2008 -0400 @@ -122,8 +122,8 @@ let val env = pushDatatype env x n xncs in - foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype n, loc) - | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype n, loc)), loc)) + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc) + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), loc)), loc)) env xncs end | DStruct (n, xts) => pushStruct env n xts diff -r 2be573fec9a6 -r 25b169416ea8 src/cjr_print.sml --- a/src/cjr_print.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/cjr_print.sml Tue Jul 29 15:43:17 2008 -0400 @@ -53,7 +53,7 @@ val debug = ref false -val dummyTyp = (TDatatype 0, ErrorMsg.dummySpan) +val dummyTyp = (TDatatype (0, []), ErrorMsg.dummySpan) fun p_typ' par env (t, loc) = case t of @@ -69,7 +69,7 @@ space, string "__lws_", string (Int.toString i)] - | TDatatype n => + | TDatatype (n, _) => (box [string "struct", space, string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] @@ -445,7 +445,7 @@ string "})"] end - | TDatatype i => + | TDatatype (i, _) => let val (x, xncs) = E.lookupDatatype env i diff -r 2be573fec9a6 -r 25b169416ea8 src/cjrize.sml --- a/src/cjrize.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/cjrize.sml Tue Jul 29 15:43:17 2008 -0400 @@ -84,7 +84,21 @@ in ((L'.TRecord si, loc), sm) end - | L.TNamed n => ((L'.TDatatype n, loc), sm) + | L.TDatatype (n, xncs) => + let + val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) => + case to of + NONE => ((x, n, NONE), sm) + | SOME t => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, n, SOME t), sm) + end) + sm xncs + in + ((L'.TDatatype (n, xncs), loc), sm) + end | L.TFfi mx => ((L'.TFfi mx, loc), sm) val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan) diff -r 2be573fec9a6 -r 25b169416ea8 src/core_env.sig --- a/src/core_env.sig Tue Jul 29 15:25:42 2008 -0400 +++ b/src/core_env.sig Tue Jul 29 15:43:17 2008 -0400 @@ -42,6 +42,9 @@ val pushCNamed : env -> string -> int -> Core.kind -> Core.con option -> env val lookupCNamed : env -> int -> string * Core.kind * Core.con option + val pushDatatype : env -> string -> int -> (string * int * Core.con option) list -> env + val lookupDatatype : env -> int -> string * (string * int * Core.con option) list + val pushERel : env -> string -> Core.con -> env val lookupERel : env -> int -> string * Core.con diff -r 2be573fec9a6 -r 25b169416ea8 src/core_env.sml --- a/src/core_env.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/core_env.sml Tue Jul 29 15:43:17 2008 -0400 @@ -61,6 +61,8 @@ relC : (string * kind) list, namedC : (string * kind * con option) IM.map, + datatypes : (string * (string * int * con option) list) IM.map, + relE : (string * con) list, namedE : (string * con * exp option * string) IM.map } @@ -69,6 +71,8 @@ relC = [], namedC = IM.empty, + datatypes = IM.empty, + relE = [], namedE = IM.empty } @@ -77,6 +81,8 @@ {relC = (x, k) :: #relC env, namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env), + datatypes = #datatypes env, + relE = map (fn (x, c) => (x, lift c)) (#relE env), namedE = IM.map (fn (x, c, eo, s) => (x, lift c, eo, s)) (#namedE env)} @@ -88,6 +94,8 @@ {relC = #relC env, namedC = IM.insert (#namedC env, n, (x, k, co)), + datatypes = #datatypes env, + relE = #relE env, namedE = #namedE env} @@ -96,10 +104,26 @@ NONE => raise UnboundNamed n | SOME x => x +fun pushDatatype (env : env) x n xncs = + {relC = #relC env, + namedC = #namedC env, + + datatypes = IM.insert (#datatypes env, n, (x, xncs)), + + relE = #relE env, + namedE = #namedE env} + +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of + NONE => raise UnboundNamed n + | SOME x => x + fun pushERel (env : env) x t = {relC = #relC env, namedC = #namedC env, + datatypes = #datatypes env, + relE = (x, t) :: #relE env, namedE = #namedE env} @@ -111,6 +135,8 @@ {relC = #relC env, namedC = #namedC env, + datatypes = #datatypes env, + relE = #relE env, namedE = IM.insert (#namedE env, n, (x, t, eo, s))} @@ -124,6 +150,7 @@ DCon (x, n, k, c) => pushCNamed env x n k (SOME c) | DDatatype (x, n, xncs) => let + val env = pushDatatype env x n xncs val env = pushCNamed env x n (KType, loc) NONE in foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (CNamed n, loc) NONE "" diff -r 2be573fec9a6 -r 25b169416ea8 src/mono.sml --- a/src/mono.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono.sml Tue Jul 29 15:43:17 2008 -0400 @@ -32,7 +32,7 @@ datatype typ' = TFun of typ * typ | TRecord of (string * typ) list - | TNamed of int + | TDatatype of int * (string * int * typ option) list | TFfi of string * string withtype typ = typ' located diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_env.sig --- a/src/mono_env.sig Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_env.sig Tue Jul 29 15:43:17 2008 -0400 @@ -34,8 +34,8 @@ exception UnboundRel of int exception UnboundNamed of int - val pushTNamed : env -> string -> int -> Mono.typ option -> env - val lookupTNamed : env -> int -> string * Mono.typ option + val pushDatatype : env -> string -> int -> (string * int * Mono.typ option) list -> env + val lookupDatatype : env -> int -> string * (string * int * Mono.typ option) list val pushERel : env -> string -> Mono.typ -> env val lookupERel : env -> int -> string * Mono.typ diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_env.sml --- a/src/mono_env.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_env.sml Tue Jul 29 15:43:17 2008 -0400 @@ -36,32 +36,32 @@ exception UnboundNamed of int type env = { - namedT : (string * typ option) IM.map, + datatypes : (string * (string * int * typ option) list) IM.map, relE : (string * typ) list, namedE : (string * typ * exp option * string) IM.map } val empty = { - namedT = IM.empty, + datatypes = IM.empty, relE = [], namedE = IM.empty } -fun pushTNamed (env : env) x n co = - {namedT = IM.insert (#namedT env, n, (x, co)), +fun pushDatatype (env : env) x n xncs = + {datatypes = IM.insert (#datatypes env, n, (x, xncs)), relE = #relE env, namedE = #namedE env} -fun lookupTNamed (env : env) n = - case IM.find (#namedT env, n) of +fun lookupDatatype (env : env) n = + case IM.find (#datatypes env, n) of NONE => raise UnboundNamed n | SOME x => x fun pushERel (env : env) x t = - {namedT = #namedT env, + {datatypes = #datatypes env, relE = (x, t) :: #relE env, namedE = #namedE env} @@ -71,7 +71,7 @@ handle Subscript => raise UnboundRel n fun pushENamed (env : env) x n t eo s = - {namedT = #namedT env, + {datatypes = #datatypes env, relE = #relE env, namedE = IM.insert (#namedE env, n, (x, t, eo, s))} @@ -85,10 +85,10 @@ case d of DDatatype (x, n, xncs) => let - val env = pushTNamed env x n NONE + val env = pushDatatype env x n xncs in - foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc) NONE "" - | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc) NONE "") + foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc) NONE "" + | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), loc)), loc) NONE "") env xncs end | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_print.sml --- a/src/mono_print.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_print.sml Tue Jul 29 15:43:17 2008 -0400 @@ -53,11 +53,11 @@ space, p_typ env t]) xcs, string "}"] - | TNamed n => + | TDatatype (n, _) => if !debug then - string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n) + string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n) else - string (#1 (E.lookupTNamed env n)) + string (#1 (E.lookupDatatype env n)) | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] and p_typ env = p_typ' false env @@ -164,7 +164,7 @@ fun p_datatype env (x, n, cons) = let - val env = E.pushTNamed env x n NONE + val env = E.pushDatatype env x n cons in box [string "datatype", space, diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_reduce.sml --- a/src/mono_reduce.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_reduce.sml Tue Jul 29 15:43:17 2008 -0400 @@ -62,7 +62,7 @@ fun bind (env, b) = case b of - U.Decl.NamedT (x, n, co) => E.pushTNamed env x n co + U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs | U.Decl.RelE (x, t) => E.pushERel env x t | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_shake.sml --- a/src/mono_shake.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_shake.sml Tue Jul 29 15:43:17 2008 -0400 @@ -56,7 +56,7 @@ fun typ (c, s) = case c of - TNamed n => + TDatatype (n, _) => if IS.member (#con s, n) then s else diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_util.sig --- a/src/mono_util.sig Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_util.sig Tue Jul 29 15:43:17 2008 -0400 @@ -45,7 +45,7 @@ structure Exp : sig datatype binder = - NamedT of string * int * Mono.typ option + Datatype of string * int * (string * int * Mono.typ option) list | RelE of string * Mono.typ | NamedE of string * int * Mono.typ * Mono.exp option * string diff -r 2be573fec9a6 -r 25b169416ea8 src/mono_util.sml --- a/src/mono_util.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/mono_util.sml Tue Jul 29 15:43:17 2008 -0400 @@ -57,7 +57,7 @@ in joinL compareFields (xts1, xts2) end - | (TNamed n1, TNamed n2) => Int.compare (n1, n2) + | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2) | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2)) | (TFun _, _) => LESS @@ -66,8 +66,8 @@ | (TRecord _, _) => LESS | (_, TRecord _) => GREATER - | (TNamed _, _) => LESS - | (_, TNamed _) => GREATER + | (TDatatype _, _) => LESS + | (_, TDatatype _) => GREATER and compareFields ((x1, t1), (x2, t2)) = join (String.compare (x1, x2), @@ -95,7 +95,7 @@ (x, t'))) xts, fn xts' => (TRecord xts', loc)) - | TNamed _ => S.return2 cAll + | TDatatype _ => S.return2 cAll | TFfi _ => S.return2 cAll in mft @@ -125,7 +125,7 @@ structure Exp = struct datatype binder = - NamedT of string * int * typ option + Datatype of string * int * (string * int * typ option) list | RelE of string * typ | NamedE of string * int * typ * exp option * string @@ -324,8 +324,8 @@ case #1 d' of DDatatype (x, n, xncs) => let - val ctx = bind (ctx, NamedT (x, n, NONE)) - val t = (TNamed n, #2 d') + val ctx = bind (ctx, Datatype (x, n, xncs)) + val t = (TDatatype (n, xncs), #2 d') in foldl (fn ((x, n, to), ctx) => let diff -r 2be573fec9a6 -r 25b169416ea8 src/monoize.sml --- a/src/monoize.sml Tue Jul 29 15:25:42 2008 -0400 +++ b/src/monoize.sml Tue Jul 29 15:43:17 2008 -0400 @@ -33,7 +33,7 @@ structure L = Core structure L' = Mono -val dummyTyp = (L'.TNamed 0, E.dummySpan) +val dummyTyp = (L'.TDatatype (0, []), E.dummySpan) fun monoName env (all as (c, loc)) = let @@ -65,7 +65,14 @@ (L'.TFfi ("Basis", "string"), loc) | L.CRel _ => poly () - | L.CNamed n => (L'.TNamed n, loc) + | L.CNamed n => + let + val (_, xncs) = Env.lookupDatatype env n + + val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs + in + (L'.TDatatype (n, xncs), loc) + end | L.CFfi mx => (L'.TFfi mx, loc) | L.CApp _ => poly () | L.CAbs _ => poly () @@ -115,7 +122,7 @@ | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc) | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc) - | L'.TNamed _ => (L'.EPrim (Prim.String "A"), loc) + | L'.TDatatype _ => (L'.EPrim (Prim.String "A"), loc) | _ => (E.errorAt loc "Don't know how to encode attribute type"; Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];