summaryrefslogtreecommitdiff
path: root/src/cjr_print.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-08-03 12:43:20 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-08-03 12:43:20 -0400
commit6314b4c27a14576b356258dad74607168135cb51 (patch)
treeec853f9102b3d3e5729457db7a10fd4f81165431 /src/cjr_print.sml
parent1798f5eb1b11613d88acb307472922976f1583b4 (diff)
Compiled pattern matching to C
Diffstat (limited to 'src/cjr_print.sml')
-rw-r--r--src/cjr_print.sml261
1 files changed, 255 insertions, 6 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 61b2d6ce..4a6971b0 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -85,7 +85,188 @@ fun p_enamed env n =
string ("__lwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
handle CjrEnv.UnboundNamed _ => string ("__lwn_UNBOUND_" ^ Int.toString n)
-fun p_exp' par env (e, _) =
+fun p_con_named env n =
+ string ("__lwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
+ handle CjrEnv.UnboundNamed _ => string ("__lwc_UNBOUND_" ^ Int.toString n)
+
+fun p_pat_preamble env (p, _) =
+ case p of
+ PWild => (box [],
+ env)
+ | PVar (x, t) => (box [p_typ env t,
+ space,
+ string "__lwr_",
+ string x,
+ string "_",
+ string (Int.toString (E.countERels env)),
+ string ";",
+ newline],
+ env)
+ | PPrim _ => (box [], env)
+ | PCon (_, NONE) => (box [], env)
+ | PCon (_, SOME p) => p_pat_preamble env p
+ | PRecord xps =>
+ foldl (fn ((_, p, _), (pp, env)) =>
+ let
+ val (pp', env) = p_pat_preamble env p
+ in
+ (box [pp', pp], env)
+ end) (box [], env) xps
+
+fun p_patCon env pc =
+ case pc of
+ PConVar n => p_con_named env n
+ | PConFfi _ => raise Fail "CjrPrint PConFfi"
+
+fun p_pat (env, exit, depth) (p, _) =
+ case p of
+ PWild =>
+ (box [], env)
+ | PVar (x, t) =>
+ (box [string "__lwr_",
+ string x,
+ string "_",
+ string (Int.toString (E.countERels env)),
+ space,
+ string "=",
+ space,
+ string "disc",
+ string (Int.toString depth),
+ string ";"],
+ E.pushERel env x t)
+ | PPrim (Prim.Int n) =>
+ (box [string "if",
+ space,
+ string "(disc",
+ string (Int.toString depth),
+ space,
+ string "!=",
+ space,
+ Prim.p_t (Prim.Int n),
+ string ")",
+ space,
+ exit],
+ env)
+ | PPrim (Prim.String s) =>
+ (box [string "if",
+ space,
+ string "(strcmp(disc",
+ string (Int.toString depth),
+ string ",",
+ space,
+ Prim.p_t (Prim.String s),
+ string "))",
+ space,
+ exit],
+ env)
+ | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
+
+ | PCon (pc, po) =>
+ let
+ val (p, env) =
+ case po of
+ NONE => (box [], env)
+ | SOME p =>
+ let
+ val (p, env) = p_pat (env, exit, depth + 1) p
+
+ val (x, to) = case pc of
+ PConVar n =>
+ let
+ val (x, to, _) = E.lookupConstructor env n
+ in
+ (x, to)
+ end
+ | PConFfi _ => raise Fail "PConFfi"
+
+ val t = case to of
+ NONE => raise Fail "CjrPrint: Constructor mismatch"
+ | SOME t => t
+ in
+ (box [string "{",
+ newline,
+ p_typ env t,
+ space,
+ string "disc",
+ string (Int.toString (depth + 1)),
+ space,
+ string "=",
+ space,
+ string "disc",
+ string (Int.toString depth),
+ string "->data.__lwc_",
+ string x,
+ string ";",
+ newline,
+ p,
+ newline,
+ string "}"],
+ env)
+ end
+ in
+ (box [string "if",
+ space,
+ string "(disc",
+ string (Int.toString depth),
+ string "->tag",
+ space,
+ string "!=",
+ space,
+ p_patCon env pc,
+ string ")",
+ space,
+ exit,
+ newline,
+ p],
+ env)
+ end
+
+ | PRecord xps =>
+ let
+ val (xps, env) =
+ ListUtil.foldlMap (fn ((x, p, t), env) =>
+ let
+ val (p, env) = p_pat (env, exit, depth + 1) p
+
+ val p = box [string "{",
+ newline,
+ p_typ env t,
+ space,
+ string "disc",
+ string (Int.toString (depth + 1)),
+ space,
+ string "=",
+ space,
+ string "disc",
+ string (Int.toString depth),
+ string ".",
+ string x,
+ string ";",
+ newline,
+ p,
+ newline,
+ string "}"]
+ in
+ (p, env)
+ end) env xps
+ in
+ (p_list_sep newline (fn x => x) xps,
+ env)
+ end
+
+local
+ val count = ref 0
+in
+fun newGoto () =
+ let
+ val r = !count
+ in
+ count := r + 1;
+ string ("L" ^ Int.toString r)
+ end
+end
+
+fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t p
| ERel n => p_rel env n
@@ -95,7 +276,7 @@ fun p_exp' par env (e, _) =
val (x, _, dn) = E.lookupConstructor env n
val (dx, _) = E.lookupDatatype env dn
in
- box [string "{(",
+ box [string "({",
newline,
string "struct",
space,
@@ -123,7 +304,7 @@ fun p_exp' par env (e, _) =
newline,
case eo of
NONE => box []
- | SOME e => box [string "tmp->data.",
+ | SOME e => box [string "tmp->data.__lwc_",
string x,
space,
string "=",
@@ -180,10 +361,77 @@ fun p_exp' par env (e, _) =
string "})" ]
| EField (e, x) =>
box [p_exp' true env e,
- string ".",
+ string ".__lwf_",
string x]
- | ECase _ => raise Fail "CjrPrint ECase"
+ | ECase (e, pes, {disc, result}) =>
+ let
+ val final = newGoto ()
+
+ val body = foldl (fn ((p, e), body) =>
+ let
+ val exit = newGoto ()
+ val (pr, _) = p_pat_preamble env p
+ val (p, env) = p_pat (env,
+ box [string "goto",
+ space,
+ exit,
+ string ";"],
+ 0) p
+ in
+ box [body,
+ box [string "{",
+ newline,
+ pr,
+ newline,
+ p,
+ newline,
+ string "result",
+ space,
+ string "=",
+ space,
+ p_exp env e,
+ string ";",
+ newline,
+ string "goto",
+ space,
+ final,
+ string ";",
+ newline,
+ string "}"],
+ newline,
+ exit,
+ string ":",
+ newline]
+ end) (box []) pes
+ in
+ box [string "({",
+ newline,
+ p_typ env disc,
+ space,
+ string "disc0",
+ space,
+ string "=",
+ space,
+ p_exp env e,
+ string ";",
+ newline,
+ p_typ env result,
+ space,
+ string "result;",
+ newline,
+ body,
+ string "lw_error(ctx, FATAL, \"",
+ string (ErrorMsg.spanToString loc),
+ string ": pattern match failure\");",
+ newline,
+ final,
+ string ":",
+ space,
+ string "result;",
+ newline,
+ string "})"]
+ end
| EWrite e => box [string "(lw_write(ctx, ",
p_exp env e,
@@ -236,6 +484,7 @@ fun p_decl env (dAll as (d, _) : decl) =
newline,
p_list_sep (box []) (fn (x, t) => box [p_typ env t,
space,
+ string "__lwf_",
string x,
string ";",
newline]) xts,
@@ -538,7 +787,7 @@ fun p_file env (ds, ps) =
newline,
case to of
NONE => box []
- | SOME t => box [string "tmp->data.",
+ | SOME t => box [string "tmp->data.__lwc_",
string x',
space,
string "=",