1 (* Copyright (C) 2017 Matthew Fluet.
2 * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor XmlTree (S: XML_TREE_STRUCTS): XML_TREE =
17 structure T = HashType (S)
22 | Con of Tycon.t * t vector
30 fun maybeConstrain (x, t) =
35 then seq [x, str " : ", Type.layout t]
42 fun layoutTargs (ts: Type.t vector) =
44 andalso 0 < Vector.length ts
45 then list (Vector.toListMap (ts, Type.layout))
51 datatype t = T of {arg: (Var.t * Type.t) option,
58 fun layout (T {arg, con, targs}) =
64 maybeConstrain (seq [str " ", Var.layout x], t)]
67 fun con (T {con, ...}) = con
70 fun make c = T {con = c, targs = Vector.new0 (), arg = NONE}
72 val falsee = make Con.falsee
73 val truee = make Con.truee
80 Con of (Pat.t * 'a) vector
81 | Word of WordSize.t * (WordX.t * 'a) vector
83 fun layout (cs, layout) =
87 align (Vector.toListMap (v, fn (x, e) =>
88 align [seq [f x, str " => "],
89 indent (layout e, 3)]))
92 Con v => doit (v, Pat.layout)
93 | Word (_, v) => doit (v, WordX.layout)
96 fun fold (c: 'a t, b: 'b, f: 'a * 'b -> 'b): 'b =
98 fun doit l = Vector.fold (l, b, fn ((_, a), b) => f (a, b))
102 | Word (_, l) => doit l
105 fun map (c: 'a t, f: 'a -> 'b): 'b t =
107 fun doit l = Vector.map (l, fn (i, x) => (i, f x))
110 Con l => Con (doit l)
111 | Word (s, l) => Word (s, doit l)
114 fun foreach (c, f) = fold (c, (), fn (x, ()) => f x)
116 fun foreach' (c: 'a t, f: 'a -> unit, fc: Pat.t -> unit): unit =
118 fun doit l = Vector.foreach (l, fn (_, a) => f a)
121 Con l => Vector.foreach (l, fn (c, a) => (fc c; f a))
122 | Word (_, l) => doit l
128 datatype t = T of {targs: Type.t vector,
131 fun equals (T {targs = targs1, var = var1},
132 T {targs = targs2, var = var2}) =
133 Var.equals (var1, var2)
134 andalso Vector.equals (targs1, targs2, Type.equals)
136 fun mono var = T {var = var, targs = Vector.new0 ()}
139 fun make f (T r) = f r
144 fun layout (T {var, targs, ...}) =
145 if !Control.showTypes
148 if Vector.isEmpty targs
150 else seq [Var.layout var, str " ",
151 Vector.layout Type.layout targs]
156 (*---------------------------------------------------*)
157 (* Expressions and Declarations *)
158 (*---------------------------------------------------*)
161 Exp of {decs: dec list,
164 App of {func: VarExp.t,
166 | Case of {test: VarExp.t,
168 default: (exp * Region.t) option}
169 | ConApp of {con: Con.t,
170 targs: Type.t vector,
171 arg: VarExp.t option}
173 | Handle of {try: exp,
174 catch: Var.t * Type.t,
177 | PrimApp of {args: VarExp.t vector,
179 targs: Type.t vector}
180 | Profile of ProfileExp.t
181 | Raise of {exn: VarExp.t, extend: bool}
182 | Select of {tuple: VarExp.t,
184 | Tuple of VarExp.t vector
187 Exception of {arg: Type.t option,
189 | Fun of {decs: {lambda: lambda,
192 tyvars: Tyvar.t vector}
193 | MonoVal of {exp: primExp,
196 | PolyVal of {exp: exp,
198 tyvars: Tyvar.t vector,
200 and lambda = Lam of {arg: Var.t,
204 plist: PropertyList.t}
209 fun layoutConArg {arg, con} =
213 | SOME t => seq [str " of ", Type.layout t]]
214 fun layoutTyvars ts =
215 case Vector.length ts of
217 | _ => seq [tuple (Vector.toListMap (ts, Tyvar.layout)), str " "]
221 seq [str "exception ", layoutConArg ca]
222 | Fun {decs, tyvars} =>
223 align [seq [str "val rec ", layoutTyvars tyvars],
224 indent (align (Vector.toListMap
225 (decs, fn {lambda, ty, var} =>
226 align [seq [maybeConstrain (Var.layout var, ty),
228 indent (layoutLambda lambda, 3)])),
230 | MonoVal {exp, ty, var} =>
231 align [seq [str "val ",
232 maybeConstrain (Var.layout var, ty), str " = "],
233 indent (layoutPrimExp exp, 3)]
234 | PolyVal {exp, ty, tyvars, var} =>
235 align [seq [str "val ",
236 if !Control.showTypes
237 then layoutTyvars tyvars
239 maybeConstrain (Var.layout var, ty),
241 indent (layoutExp exp, 3)]
242 and layoutExp (Exp {decs, result}) =
244 indent (align (List.map (decs, layoutDec)), 3),
246 indent (VarExp.layout result, 3),
248 and layoutPrimExp e =
250 App {arg, func} => seq [VarExp.layout func, str " ", VarExp.layout arg]
251 | Case {test, cases, default} =>
252 align [seq [str "case",
253 case cases of Cases.Con _ => empty
254 | Cases.Word (size, _) => str (WordSize.toString size),
255 str " ", VarExp.layout test, str " of"],
256 Cases.layout (cases, layoutExp),
261 | SOME (e, _) => seq [str "_ => ", layoutExp e]],
263 | ConApp {arg, con, targs, ...} =>
269 | SOME x => seq [str " ", VarExp.layout x]]
270 | Const c => Const.layout c
271 | Handle {catch, handler, try} =>
272 align [layoutExp try,
274 maybeConstrain (Var.layout (#1 catch), #2 catch),
275 str " => ", layoutExp handler]]
276 | Lambda l => layoutLambda l
277 | PrimApp {args, prim, targs} =>
279 Prim.layoutFull(prim, Type.layout),
281 str " ", tuple (Vector.toListMap (args, VarExp.layout))]
282 | Profile e => ProfileExp.layout e
283 | Raise {exn, extend} =>
285 str (if extend then "extend " else ""),
287 | Select {offset, tuple} =>
288 seq [str "#", Int.layout offset, str " ", VarExp.layout tuple]
289 | Tuple xs => tuple (Vector.toList
290 (Vector.mapi(xs, fn (i, x) => seq
291 (* very specific case to prevent open comments *)
292 [str (if i = 0 andalso
293 (case x of (VarExp.T {var, ...}) =>
294 String.sub(Var.toString var, 0) = #"*")
298 | Var x => VarExp.layout x
299 and layoutLambda (Lam {arg, argType, body, mayInline, ...}) =
300 align [seq [str "fn ",
301 str (if not mayInline then "noinline " else ""),
302 maybeConstrain (Var.layout arg, argType),
311 datatype t = datatype dec
313 val layout = layoutDec
319 datatype t = datatype primExp
321 val layout = layoutPrimExp
326 datatype t = datatype exp
328 val layout = layoutExp
331 val decs = #decs o dest
332 val result = #result o dest
334 fun fromPrimExp (exp: PrimExp.t, ty: Type.t): t =
335 let val var = Var.newNoname ()
336 in Exp {decs = [Dec.MonoVal {var = var, ty = ty, exp = exp}],
337 result = VarExp.mono var}
341 fun make f (Exp {decs, result}, d) =
342 Exp {decs = f (d, decs),
344 in val prefix = make (op ::)
345 val prefixs = make (op @)
348 fun enterLeave (e: t, ty: Type.t, si: SourceInfo.t): t =
350 datatype z = datatype Dec.t
351 datatype z = datatype PrimExp.t
353 MonoVal {exp = Profile (f si),
355 var = Var.newNoname ()}
356 val exn = Var.newNoname ()
357 val res = Var.newNoname ()
359 make {decs = [prof ProfileExp.Leave,
360 MonoVal {exp = Raise {exn = VarExp.mono exn,
364 result = VarExp.mono res}
366 if !Control.profile = Control.ProfileCount
369 val unit = Var.newNoname ()
371 [MonoVal {exp = Tuple (Vector.new0 ()),
375 {exp = PrimApp {args = Vector.new1 (VarExp.mono unit),
377 targs = Vector.new1 Type.unit},
379 var = Var.newNoname ()}]
382 val {decs, result} = dest e
384 List.concat [[prof ProfileExp.Enter],
387 [prof ProfileExp.Leave]]
388 val try = make {decs = decs, result = result}
390 fromPrimExp (Handle {catch = (exn, Type.exn),
396 (*------------------------------------*)
398 (*------------------------------------*)
400 handleExp: t -> unit,
401 handlePrimExp: Var.t * Type.t * PrimExp.t -> unit,
402 handleBoundVar: Var.t * Tyvar.t vector * Type.t -> unit,
403 handleVarExp: VarExp.t -> unit}: unit =
405 fun monoVar (x, t) = handleBoundVar (x, Vector.new0 (), t)
406 fun handleVarExps xs = Vector.foreach (xs, handleVarExp)
408 let val {decs, result} = dest e
409 in List.foreach (decs, loopDec)
410 ; handleVarExp result
413 and loopPrimExp (x: Var.t, ty: Type.t, e: PrimExp.t): unit =
414 (handlePrimExp (x, ty, e)
417 | Var x => handleVarExp x
418 | Tuple xs => handleVarExps xs
419 | Select {tuple, ...} => handleVarExp tuple
420 | Lambda lambda => loopLambda lambda
421 | PrimApp {args, ...} => handleVarExps args
423 | ConApp {arg, ...} => (case arg of
425 | SOME x => handleVarExp x)
426 | App {func, arg} => (handleVarExp func
428 | Raise {exn, ...} => handleVarExp exn
429 | Handle {try, catch, handler, ...} =>
433 | Case {test, cases, default} =>
435 ; Cases.foreach' (cases, loopExp,
436 fn Pat.T {arg, ...} =>
439 | SOME x => monoVar x)
440 ; Option.app (default, loopExp o #1))))
443 MonoVal {var, ty, exp} =>
444 (monoVar (var, ty); loopPrimExp (var, ty, exp))
445 | PolyVal {var, tyvars, ty, exp} =>
446 (handleBoundVar (var, tyvars, ty)
449 | Fun {tyvars, decs, ...} =>
450 (Vector.foreach (decs, fn {ty, var, ...} =>
451 handleBoundVar (var, tyvars, ty))
452 ; Vector.foreach (decs, fn {lambda, ...} =>
454 and loopLambda (Lam {arg, argType, body, ...}): unit =
455 (monoVar (arg, argType); loopExp body)
461 fun foreachPrimExp (e, f) =
465 handleBoundVar = ignore,
466 handleVarExp = ignore}
468 fun foreachVarExp (e, f) =
470 handlePrimExp = ignore,
472 handleBoundVar = ignore,
475 fun foreachBoundVar (e, f) =
477 handlePrimExp = ignore,
480 handleVarExp = ignore}
482 fun foreachExp (e, f) =
484 handlePrimExp = ignore,
486 handleBoundVar = ignore,
487 handleVarExp = ignore}
488 (* quell unused warning *)
494 (foreachPrimExp (e, fn (_, _, e) =>
496 PrimApp {prim, ...} => if f prim then escape true
502 let val n: int ref = ref 0
503 fun inc () = n := 1 + !n
504 in foreachPrimExp (e, fn _ => inc ());
507 val size = Trace.trace ("XmlTree.Exp.size", Layout.ignore, Int.layout) size
508 (* quell unused warning *)
511 fun clear (e: t): unit =
513 fun clearTyvars ts = Vector.foreach (ts, Tyvar.clear)
514 fun clearPat (Pat.T {arg, ...}) =
517 | SOME (x, _) => Var.clear x
518 fun clearExp e = clearDecs (decs e)
519 and clearDecs ds = List.foreach (ds, clearDec)
522 MonoVal {var, exp, ...} => (Var.clear var; clearPrimExp exp)
523 | PolyVal {var, tyvars, exp, ...} =>
527 | Fun {tyvars, decs} =>
529 ; Vector.foreach (decs, fn {var, lambda, ...} =>
531 ; clearLambda lambda)))
532 | Exception {con, ...} => Con.clear con
535 Lambda l => clearLambda l
536 | Case {cases, default, ...} =>
537 (Cases.foreach' (cases, clearExp, clearPat)
538 ; Option.app (default, clearExp o #1))
539 | Handle {try, catch, handler, ...} =>
541 ; Var.clear (#1 catch)
544 and clearLambda (Lam {arg, body, ...}) =
545 (Var.clear arg; clearExp body)
550 (*---------------------------------------------------*)
552 (*---------------------------------------------------*)
557 datatype t = datatype lambda
560 fun make f (Lam r) = f r
563 val body = make #body
564 val mayInline = make #mayInline
567 fun make {arg, argType, body, mayInline} =
571 mayInline = mayInline,
572 plist = PropertyList.new ()}
574 fun dest (Lam {arg, argType, body, mayInline, ...}) =
575 {arg = arg, argType = argType, body = body, mayInline = mayInline}
577 fun plist (Lam {plist, ...}) = plist
579 val layout = layoutLambda
580 fun equals (f:t, f':t) = PropertyList.equals (plist f, plist f')
583 (* ------------------------------------------------- *)
585 (* ------------------------------------------------- *)
586 structure DirectExp =
592 type t = PrimExp.t * Type.t -> Exp.t
594 fun nameGen (k: VarExp.t * Type.t -> Exp.t): t =
598 | _ => let val x = Var.newNoname ()
599 in Exp.prefix (k (VarExp.mono x, t),
600 MonoVal {var = x, ty = t, exp = e})
603 fun name (k: VarExp.t * Type.t -> Exp.t): t = nameGen k
605 val id: t = name (fn (x, _) => Exp {decs = [], result = x})
607 fun return (k: t, xt) = k xt
610 type t = Cont.t -> Exp.t
612 fun send (e: t, k: Cont.t): Exp.t = e k
614 fun toExp e = send (e, Cont.id)
616 fun fromExp (Exp {decs, result}, ty): t =
617 fn k => Exp.prefixs (k (Var result, ty), decs)
619 fun sendName (e, k) = send (e, Cont.name k)
621 fun simple (e: PrimExp.t * Type.t) k = Cont.return (k, e)
623 fun const c = simple (Const c, Type.ofConst c)
625 val string = const o Const.string
627 fun varExp (x, t) = simple (Var x, t)
629 fun var {var, targs, ty} =
630 varExp (VarExp.T {var = var, targs = targs}, ty)
632 fun monoVar (x, t) = var {var = x, targs = Vector.new0 (), ty = t}
634 fun convertsGen (es: t vector,
635 k: (VarExp.t * Type.t) vector -> Exp.t): Exp.t =
637 val n = Vector.length es
640 then k (Vector.fromListRev xs)
641 else sendName (Vector.sub (es, i),
642 fn x => loop (i + 1, x :: xs))
646 fun converts (es: t vector,
647 make: (VarExp.t * Type.t) vector -> PrimExp.t * Type.t): t =
648 fn k => convertsGen (es, k o make)
650 fun convert (e: t, make: VarExp.t * Type.t -> PrimExp.t * Type.t): t =
651 fn k => send (e, Cont.name (k o make))
653 fun convertOpt (e, make) =
655 NONE => simple (make NONE)
656 | SOME e => convert (e, make o SOME o #1)
658 fun tuple {exps: t vector, ty: Type.t}: t =
659 if 1 = Vector.length exps
660 then Vector.first exps
661 else converts (exps, fn xs =>
662 (PrimExp.Tuple (Vector.map (xs, #1)), ty))
664 fun select {tuple, offset, ty} =
665 convert (tuple, fn (tuple, _) =>
666 (Select {tuple = tuple, offset = offset}, ty))
668 fun conApp {con, targs, arg, ty} =
669 convertOpt (arg, fn arg =>
670 (ConApp {con = con, targs = targs, arg = arg}, ty))
675 targs = Vector.new0 (),
679 val truee = make Con.truee
680 val falsee = make Con.falsee
683 fun primApp {prim, targs, args, ty} =
684 converts (args, fn args =>
685 (PrimApp {prim = prim,
687 args = Vector.map (args, #1)},
690 fun convert2 (e1, e2, make) =
691 converts (Vector.new2 (e1, e2),
692 fn xs => make (Vector.first xs, Vector.sub (xs, 1)))
694 fun app {func, arg, ty} =
695 convert2 (func, arg, fn ((func, _), (arg, _)) =>
696 (App {func = func, arg = arg}, ty))
698 fun casee {test, cases, default, ty} =
699 convert (test, fn (test, _) =>
702 cases = Cases.map (cases, toExp),
703 default = (Option.map
704 (default, fn (e, r) => (toExp e, r)))},
707 fun raisee {exn: t, extend: bool, ty: Type.t}: t =
708 convert (exn, fn (x, _) => (Raise {exn = x, extend = extend}, ty))
710 fun handlee {try, catch, handler, ty} =
711 simple (Handle {try = toExp try,
713 handler = toExp handler},
716 fun unit () = tuple {exps = Vector.new0 (), ty = Type.unit}
719 convert (e, fn (x, t) =>
720 (PrimApp {prim = Prim.reff,
721 targs = Vector.new1 t,
722 args = Vector.new1 x},
725 fun deref (e: t): t =
726 convert (e, fn (x, t) =>
730 (PrimApp {prim = Prim.deref,
731 targs = Vector.new1 t,
732 args = Vector.new1 x},
736 fun vectorLength (e: t): t =
737 convert (e, fn (x, t) =>
739 val t = Type.deVector t
741 (PrimApp {prim = Prim.vectorLength,
742 targs = Vector.new1 t,
743 args = Vector.new1 x},
744 Type.word (WordSize.seqIndex ()))
747 fun vectorSub (e1: t, e2: t): t =
748 convert2 (e1, e2, fn ((x1, t1), (x2, _)) =>
750 val t = Type.deVector t1
752 (PrimApp {prim = Prim.vectorSub,
753 targs = Vector.new1 t,
754 args = Vector.new2 (x1, x2)},
759 convert2 (e1, e2, fn ((x1, t), (x2, _)) =>
760 (PrimApp {prim = Prim.equal,
761 targs = Vector.new1 t,
762 args = Vector.new2 (x1, x2)},
765 fun iff {test, thenn, elsee, ty} =
767 cases = Cases.Con (Vector.new2 ((Pat.truee, thenn),
768 (Pat.falsee, elsee))),
772 fun vall {var, exp}: Dec.t list =
773 let val t = ref Type.unit
774 val Exp {decs, result} =
775 sendName (exp, fn (x, t') => (t := t';
776 Exp {decs = [], result = x}))
777 in decs @ [MonoVal {var = var, ty = !t, exp = Var result}]
781 converts (es, fn xs => let val (x, t) = Vector.last xs
785 val bug: string -> t =
787 primApp {prim = Prim.bug,
788 targs = Vector.new0 (),
789 args = Vector.new1 (string s),
793 fn k => convertsGen (es, fn xts =>
794 send (make (Vector.map (xts, varExp)), k))
796 fun lett {decs, body} = fn k => Exp.prefixs (send (body, k), decs)
798 fun let1 {var, exp, body} =
800 send (exp, fn (exp, ty) =>
801 Exp.prefix (send (body, k),
802 Dec.MonoVal {var = var, ty = ty, exp = exp}))
804 fun lambda {arg, argType, body, bodyType, mayInline} =
805 simple (Lambda (Lambda.make {arg = arg,
808 mayInline = mayInline}),
809 Type.arrow (argType, bodyType))
811 fun fromLambda (l, ty) =
812 simple (Lambda l, ty)
814 fun detupleGen (e: PrimExp.t,
816 components: Var.t vector,
817 body: Exp.t): Exp.t =
820 case Vector.length components of
822 | 1 => [MonoVal {var = Vector.first components, ty = t, exp = e}]
825 val ts = Type.deTuple t
826 val tupleVar = Var.newNoname ()
827 in MonoVal {var = tupleVar, ty = t, exp = e}
830 (components, ts, (0, []),
831 fn (x, t, (i, ac)) =>
833 MonoVal {var = x, ty = t,
834 exp = Select {tuple = VarExp.mono tupleVar,
839 fun detupleBind {tuple, components, body} =
840 fn k => send (tuple, fn (e, t) => detupleGen (e, t, components, body k))
842 fun detuple {tuple: t, body}: t =
847 val ts = Type.deTuple t
850 Tuple xs => send (body (Vector.zip (xs, ts)), k)
853 Vector.map (ts, fn _ => Var.newNoname ())
855 detupleGen (e, t, components,
856 send (body (Vector.map2
857 (components, ts, fn (x, t) =>
858 (VarExp.mono x, t))),
863 fun devector {vector: t, length: int, body}: t =
869 vectorSub (vector, const (Const.word (WordX.fromIntInf (IntInf.fromInt i, WordSize.seqIndex ())))))
871 convertsGen (es, fn args => (body args) k)
875 (*---------------------------------------------------*)
877 (*---------------------------------------------------*)
881 type t = {cons: {arg: Type.t option,
884 tyvars: Tyvar.t vector}
886 fun layout ({cons, tycon, tyvars}: t): Layout.t =
890 seq [layoutTyvars tyvars,
891 Tycon.layout tycon, str " = ",
893 (separateLeft (Vector.toListMap (cons, layoutConArg),
898 (*---------------------------------------------------*)
900 (*---------------------------------------------------*)
904 datatype t = T of {body: Exp.t,
905 datatypes: Datatype.t vector,
906 overflow: Var.t option}
908 fun layout (T {body, datatypes, overflow, ...}) =
912 align [str "\n\nDatatypes:",
913 align (Vector.toListMap (datatypes, Datatype.layout)),
914 seq [str "\n\nOverflow: ", Option.layout Var.layout overflow],
919 fun layouts (T {body, datatypes, overflow, ...}, output') =
922 (* Layout includes an output function, so we need to rebind output
927 output (str "\n\nDatatypes:")
928 ; Vector.foreach (datatypes, output o Datatype.layout)
929 ; output (seq [str "\n\nOverflow: ", Option.layout Var.layout overflow])
930 ; output (str "\n\nBody:")
931 ; output (Exp.layout body)
934 fun clear (T {datatypes, body, ...}) =
935 (Vector.foreach (datatypes, fn {tycon, tyvars, cons} =>
937 ; Vector.foreach (tyvars, Tyvar.clear)
938 ; Vector.foreach (cons, Con.clear o #con)))
941 fun layoutStats (T {datatypes, body, ...}) =
944 fun inc _ = numTypes := 1 + !numTypes
945 val {hom, destroy} = Type.makeHom {var = inc, con = inc}
946 val numPrimExps = ref 0
949 Vector.foreach (datatypes, fn {cons, ...} =>
950 Vector.foreach (cons, fn {arg, ...} =>
956 handlePrimExp = fn _ => numPrimExps := 1 + !numPrimExps,
957 handleVarExp = fn _ => (),
958 handleBoundVar = hom o #3,
959 handleExp = fn _ => ()})
961 ; align [seq [str "num primexps in program = ", Int.layout (!numPrimExps)],
962 seq [str "num types in program = ", Int.layout (!numTypes)],