Mercurial > urweb

comparison src/cjr_print.sml @ 188:8e9f97508f0d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Datatype representation optimization
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 19:49:21 -0400
parents 88d46972de53
children 3eb53c957d10
comparison
equal deleted inserted replaced
187:fb6ed259f5bd 188:8e9f97508f0d
51 val compare = Char.compare 51 val compare = Char.compare
52 end) 52 end)
53 53
54 val debug = ref false 54 val debug = ref false
55 55
56 val dummyTyp = (TDatatype (0, []), ErrorMsg.dummySpan) 56 val dummyTyp = (TDatatype (Enum, 0, []), ErrorMsg.dummySpan)
57 57
58 fun p_typ' par env (t, loc) = 58 fun p_typ' par env (t, loc) =
59 case t of 59 case t of
60 TTop => string "void*" 60 TTop => string "void*"
61 | TFun (t1, t2) => parenIf par (box [p_typ' true env t2, 61 | TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
67 string ")"]) 67 string ")"])
68 | TRecord i => box [string "struct", 68 | TRecord i => box [string "struct",
69 space, 69 space,
70 string "__lws_", 70 string "__lws_",
71 string (Int.toString i)] 71 string (Int.toString i)]
72 | TDatatype (n, _) => 72 | TDatatype (Enum, n, _) =>
73 (box [string "enum",
74 space,
75 string ("__lwe_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n)]
76 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
77 | TDatatype (Default, n, _) =>
73 (box [string "struct", 78 (box [string "struct",
74 space, 79 space,
75 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")] 80 string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
76 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n)) 81 handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
77 | TFfi (m, x) => box [string "lw_", string m, string "_", string x] 82 | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
101 string (Int.toString (E.countERels env)), 106 string (Int.toString (E.countERels env)),
102 string ";", 107 string ";",
103 newline], 108 newline],
104 env) 109 env)
105 | PPrim _ => (box [], env) 110 | PPrim _ => (box [], env)
106 | PCon (_, NONE) => (box [], env) 111 | PCon (_, _, NONE) => (box [], env)
107 | PCon (_, SOME p) => p_pat_preamble env p 112 | PCon (_, _, SOME p) => p_pat_preamble env p
108 | PRecord xps => 113 | PRecord xps =>
109 foldl (fn ((_, p, _), (pp, env)) => 114 foldl (fn ((_, p, _), (pp, env)) =>
110 let 115 let
111 val (pp', env) = p_pat_preamble env p 116 val (pp', env) = p_pat_preamble env p
112 in 117 in
159 space, 164 space,
160 exit], 165 exit],
161 env) 166 env)
162 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive" 167 | PPrim _ => raise Fail "CjrPrint: Disallowed PPrim primitive"
163 168
164 | PCon (pc, po) => 169 | PCon (dk, pc, po) =>
165 let 170 let
166 val (p, env) = 171 val (p, env) =
167 case po of 172 case po of
168 NONE => (box [], env) 173 NONE => (box [], env)
169 | SOME p => 174 | SOME p =>
173 val (x, to) = case pc of 178 val (x, to) = case pc of
174 PConVar n => 179 PConVar n =>
175 let 180 let
176 val (x, to, _) = E.lookupConstructor env n 181 val (x, to, _) = E.lookupConstructor env n
177 in 182 in
178 (x, to) 183 ("__lwc_" ^ x, to)
179 end 184 end
180 | PConFfi _ => raise Fail "PConFfi" 185 | PConFfi {mod = m, con, arg, ...} =>
186 ("lw_" ^ m ^ "_" ^ con, arg)
181 187
182 val t = case to of 188 val t = case to of
183 NONE => raise Fail "CjrPrint: Constructor mismatch" 189 NONE => raise Fail "CjrPrint: Constructor mismatch"
184 | SOME t => t 190 | SOME t => t
185 in 191 in
192 space, 198 space,
193 string "=", 199 string "=",
194 space, 200 space,
195 string "disc", 201 string "disc",
196 string (Int.toString depth), 202 string (Int.toString depth),
197 string "->data.__lwc_", 203 string "->data.",
198 string x, 204 string x,
199 string ";", 205 string ";",
200 newline, 206 newline,
201 p, 207 p,
202 newline, 208 newline,
206 in 212 in
207 (box [string "if", 213 (box [string "if",
208 space, 214 space,
209 string "(disc", 215 string "(disc",
210 string (Int.toString depth), 216 string (Int.toString depth),
211 string "->tag", 217 case dk of
218 Enum => box []
219 | Default => string "->tag",
212 space, 220 space,
213 string "!=", 221 string "!=",
214 space, 222 space,
215 p_patCon env pc, 223 p_patCon env pc,
216 string ")", 224 string ")",
283 fun p_exp' par env (e, loc) = 291 fun p_exp' par env (e, loc) =
284 case e of 292 case e of
285 EPrim p => Prim.p_t p 293 EPrim p => Prim.p_t p
286 | ERel n => p_rel env n 294 | ERel n => p_rel env n
287 | ENamed n => p_enamed env n 295 | ENamed n => p_enamed env n
288 | ECon (pc, eo) => 296 | ECon (Enum, pc, _) => p_patCon env pc
297 | ECon (Default, pc, eo) =>
289 let 298 let
290 val (xd, xc) = patConInfo env pc 299 val (xd, xc) = patConInfo env pc
291 in 300 in
292 box [string "({", 301 box [string "({",
293 newline, 302 newline,
495 string "__lwf_", 504 string "__lwf_",
496 string x, 505 string x,
497 string ";", 506 string ";",
498 newline]) xts, 507 newline]) xts,
499 string "};"] 508 string "};"]
500 | DDatatype (x, n, xncs) => 509 | DDatatype (Enum, x, n, xncs) =>
510 box [string "enum",
511 space,
512 string ("__lwe_" ^ x ^ "_" ^ Int.toString n),
513 space,
514 string "{",
515 space,
516 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__lwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
517 space,
518 string "};"]
519 | DDatatype (Default, x, n, xncs) =>
501 let 520 let
502 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE 521 val xncsArgs = List.mapPartial (fn (x, n, NONE) => NONE
503 | (x, n, SOME t) => SOME (x, n, t)) xncs 522 | (x, n, SOME t) => SOME (x, n, t)) xncs
504 in 523 in
505 box [string "enum", 524 box [string "enum",
539 string "}", 558 string "}",
540 space, 559 space,
541 string "data;", 560 string "data;",
542 newline]), 561 newline]),
543 string "};"] 562 string "};"]
544 end 563 end
545 564
546 | DVal (x, n, t, e) => 565 | DVal (x, n, t, e) =>
547 box [p_typ env t, 566 box [p_typ env t,
548 space, 567 space,
549 string ("__lwn_" ^ x ^ "_" ^ Int.toString n), 568 string ("__lwn_" ^ x ^ "_" ^ Int.toString n),
751 string "tmp;", 770 string "tmp;",
752 newline, 771 newline,
753 string "})"] 772 string "})"]
754 end 773 end
755 774
756 | TDatatype (i, _) => 775 | TDatatype (Enum, i, _) =>
776 let
777 val (x, xncs) = E.lookupDatatype env i
778
779 fun doEm xncs =
780 case xncs of
781 [] => string ("(lw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __lwe_"
782 ^ x ^ "_" ^ Int.toString i ^ ")0)")
783 | (x', n, to) :: rest =>
784 box [string "((!strncmp(request, \"",
785 string x',
786 string "\", ",
787 string (Int.toString (size x')),
788 string ") && (request[",
789 string (Int.toString (size x')),
790 string "] == 0 || request[",
791 string (Int.toString (size x')),
792 string ("] == '/')) ? __lwc_" ^ x' ^ "_" ^ Int.toString n),
793 space,
794 string ":",
795 space,
796 doEm rest,
797 string ")"]
798 in
799 doEm xncs
800 end
801
802 | TDatatype (Default, i, _) =>
757 let 803 let
758 val (x, xncs) = E.lookupDatatype env i 804 val (x, xncs) = E.lookupDatatype env i
759 805
760 fun doEm xncs = 806 fun doEm xncs =
761 case xncs of 807 case xncs of