1 (* Copyright (C) 2015,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 Defunctorize (S: DEFUNCTORIZE_STRUCTS): DEFUNCTORIZE =
18 structure Const = Const
21 structure Clambda = Lambda
24 structure RealSize = RealSize
25 structure Record = Record
26 structure SortedRecord = SortedRecord
27 structure SourceInfo = SourceInfo
28 structure Ctype = Type
29 structure WordSize = WordSize
30 structure WordX = WordX
33 structure Field = Record.Field
38 structure Xcases = Cases
41 structure Xexp = DirectExp
42 structure Xlambda = Lambda
44 structure XprimExp = PrimExp
45 structure Tycon = Tycon
46 structure Xtype = Type
47 structure Tyvar = Tyvar
49 structure XvarExp = VarExp
52 structure NestedPat = NestedPat (open Xml)
54 structure MatchCompile =
55 MatchCompile (open CoreML
56 structure Type = Xtype
57 structure NestedPat = NestedPat
67 (v, fn {con, targs, arg, rhs} =>
79 fun detuple {tuple, body} =
82 body = fn xts => body (Vector.map
86 fun devector {vector, length, body} =
90 body = fn xts => body (Vector.map
100 fun exn (c: Con.t): Xexp.t =
103 targs = Vector.new0 (),
106 val bind = exn Con.bind
107 val match = exn Con.match
111 fun enterLeave (e: Xexp.t, t, si): Xexp.t =
112 Xexp.fromExp (Xml.Exp.enterLeave (Xexp.toExp e, t, si), t)
115 val matchDiagnostics: (unit -> unit) list ref = ref []
117 fun addMatchDiagnostic (diag, mkArg) =
119 Control.Elaborate.DiagEIW.Error =>
120 List.push (matchDiagnostics, Control.error o mkArg)
121 | Control.Elaborate.DiagEIW.Ignore => ()
122 | Control.Elaborate.DiagEIW.Warn =>
123 List.push (matchDiagnostics, Control.warning o mkArg)
124 fun showMatchDiagnostics () = List.foreach (!matchDiagnostics, fn th => th ())
127 fun casee {ctxt: unit -> Layout.t,
130 layPat: (unit -> Layout.t) option,
132 regionPat: Region.t} vector,
134 kind: (string * string),
136 matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t,
137 nonexhaustive: Control.Elaborate.DiagEIW.t,
138 redundant: Control.Elaborate.DiagEIW.t},
141 test = (test: Xexp.t, testType: Xtype.t),
144 val nonexhaustiveExnDiag = #nonexhaustiveExn matchDiags
145 val nonexhaustiveDiag = #nonexhaustive matchDiags
146 val redundantDiag = #redundant matchDiags
147 val cases = Vector.map (cases, fn {exp, layPat, pat, regionPat} =>
154 regionPat = regionPat})
155 fun raiseExn (f, mayWrap) =
157 val e = Var.newNoname ()
158 val exp = Xexp.raisee {exn = f e, extend = true, ty = caseType}
164 !profile <> ProfileNone
165 andalso !profileIL = ProfileSource
166 andalso !profileRaise
174 {name = (concat ["<raise ", kind, ">"]) :: nest,
180 Vector.new1 {exp = exp,
185 pat = NestedPat.make (NestedPat.Var e, testType),
186 regionPat = Region.bogus}]
190 datatype z = datatype Cexp.noMatch
195 raiseExn (fn e => Xexp.monoVar (e, Xtype.exn), NONE)
196 | RaiseBind => raiseExn (fn _ => Xexp.bind, SOME "Bind")
197 | RaiseMatch => raiseExn (fn _ => Xexp.match, SOME "Match")
199 fun matchCompile () =
201 val testVar = Var.newNoname ()
205 (cases, fn {exp = e, numPats, numUses, pat = p, ...} =>
207 val args = Vector.fromList (NestedPat.varsAndTypes p)
208 val (vars, tys) = Vector.unzip args
209 val func = Var.newNoname ()
210 val arg = Var.newNoname ()
211 val argType = Xtype.tuple tys
212 val funcType = Xtype.arrow (argType, caseType)
224 {tuple = Xexp.monoVar (arg, argType),
231 (if 0 = !numUses then List.push (decs, dec ()) else ()
234 {func = Xexp.monoVar (func, funcType),
236 Xexp.tuple {exps = (Vector.map
238 Xexp.monoVar (rename x, t))),
244 val (body, nonexhaustiveExamples) =
245 MatchCompile.matchCompile {caseType = caseType,
251 tyconCons = tyconCons}
252 (* Must convert to a normal expression to force everything. *)
253 val body = Xexp.toExp body
254 val nonexhaustiveExamples =
255 if noMatch = Cexp.Impossible
259 case nonexhaustiveExnDiag of
260 Control.Elaborate.DiagDI.Default =>
261 {dropOnlyExns = false}
262 | Control.Elaborate.DiagDI.Ignore =>
263 {dropOnlyExns = true}
265 nonexhaustiveExamples dropOnlyExns
268 (Xexp.let1 {var = testVar,
270 body = Xexp.lett {decs = !decs,
271 body = Xexp.fromExp (body, caseType)}},
272 nonexhaustiveExamples)
274 datatype z = datatype NestedPat.node
275 fun lett (x, e) = Xexp.let1 {var = x, exp = test, body = e}
276 fun wild e = lett (Var.newNoname (), e)
277 val (exp, nonexhaustiveExamples) =
278 if Vector.isEmpty cases
279 then Error.bug "Defunctorize.casee: case with no patterns"
282 val {exp = e, pat = p, numPats, numUses, ...} = Vector.first cases
283 fun use () = (numPats := 1; numUses := 1)
284 fun exhaustive exp = (exp, NONE)
286 case NestedPat.node p of
287 Wild => (use (); exhaustive (wild (e ())))
288 | Var x => (use (); exhaustive (lett (x, e ())))
291 val ps = SortedRecord.range rps
293 (* It's a flat record pattern.
294 * Generate the selects.
298 val t = Var.newNoname ()
299 val tuple = XvarExp.mono t
300 val tys = Xtype.deTuple testType
304 fn (p, ty, (i, decs)) =>
305 case NestedPat.node p of
311 exp = (XprimExp.Select
315 | Wild => (i + 1, decs)
316 | _ => Error.bug "Defunctorize.casee: flat record")
318 exhaustive (Xexp.let1
319 {var = t, exp = test,
325 if Vector.forall (ps, NestedPat.isVarOrWild)
326 then if Vector.length ps = 1
327 then loop (Vector.first ps)
331 | _ => matchCompile ()
335 (* diagnoseRedundant *)
338 (cases, fn {isDefault, layPat = layPat,
339 numPats, numUses, regionPat = regionPat, ...} =>
341 fun doit (msg1, msg2) =
349 str (concat [#1 kind, msg1]),
350 align [seq [str (concat [msg2, ": "]),
352 NONE => Error.bug "Defunctorize.casee: redundant match with no lay"
353 | SOME layPat => layPat ()],
357 if not isDefault andalso !numUses = 0
358 then ((* Rule with no uses; fully redundant. *)
359 doit (" has redundant " ^ #2 kind,
360 "redundant pattern"))
361 else if not isDefault andalso !numUses > 0 andalso !numUses < !numPats
362 then ((* Rule with some uses but fewer uses than pats; partially redundant. *)
363 doit (" has " ^ #2 kind ^ " with redundancy",
364 "pattern with redundancy"))
367 (* diagnoseNonexhaustive *)
370 (nonexhaustiveExamples, fn es =>
378 str (concat [#1 kind, " is not exhaustive"]),
379 align [seq [str "missing pattern: ", es],
387 Trace.trace ("Defunctorize.casee",
388 Region.layout o #region,
389 Xml.Exp.layout o Xexp.toExp)
392 fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector =
393 Vector.map (QuickSort.sortVector (v, fn ((f, _), (f', _)) =>
397 fun valDec (tyvars: Tyvar.t vector,
401 e': Xexp.t): Xexp.t =
402 Xexp.lett {body = e',
403 decs = [Xdec.PolyVal {exp = Xexp.toExp e,
412 fun list (es: Xexp.t vector, ty: Xtype.t, {forceLeftToRight: bool})
415 val targs = #2 (valOf (Xtype.deConOpt ty))
416 val eltTy = Vector.first targs
418 Xexp.conApp {arg = NONE,
422 val consArgTy = Xtype.tuple (Vector.new2 (eltTy, ty))
423 val cons: Xexp.t * Xexp.t -> Xexp.t =
426 {arg = SOME (Xexp.tuple {exps = Vector.new2 (e1, e2),
432 if not forceLeftToRight
434 (* Build the list right to left. *)
435 Vector.foldr (es, nill, fn (e, rest) =>
437 val var = Var.newNoname ()
439 Xexp.let1 {body = cons (e, monoVar (var, ty)),
443 else if Vector.length es < 20
444 then Vector.foldr (es, nill, cons)
447 val revArgTy = Xtype.tuple (Vector.new2 (ty, ty))
448 val revTy = Xtype.arrow (revArgTy, ty)
449 val revVar = Var.newString "rev"
452 {func = Xexp.monoVar (revVar, revTy),
453 arg = Xexp.tuple {exps = Vector.new2 (e1, e2),
456 fun detuple2 (tuple: Xexp.t,
457 f: XvarExp.t * XvarExp.t -> Xexp.t): Xexp.t =
458 Xexp.detuple {body = fn xs => let
459 fun x i = #1 (Vector.sub (xs, i))
464 val revArg = Var.newNoname ()
473 (Xexp.monoVar (revArg, revArgTy), fn (l, ac) =>
475 val ac = Xexp.varExp (ac, ty)
476 val consArg = Var.newNoname ()
482 ((Xpat.T {arg = NONE,
486 (Xpat.T {arg = SOME (consArg, consArgTy),
490 (Xexp.monoVar (consArg, consArgTy),
492 rev (Xexp.varExp (l, ty),
493 cons (Xexp.varExp (x, eltTy),
496 test = Xexp.varExp (l, ty),
501 {decs = Vector.new1 {lambda = revLambda,
504 tyvars = Vector.new0 ()}
505 val l = Var.newNoname ()
508 (es, (l, Xexp.lett {decs = [revDec],
509 body = rev (Xexp.monoVar (l, ty),
513 val l' = Var.newNoname ()
516 Xexp.let1 {body = body,
517 exp = cons (e, Xexp.monoVar (l', ty)),
521 Xexp.let1 {body = body,
528 fun defunctorize (CoreML.Program.T {decs}) =
530 val {get = conExtraArgs: Con.t -> Xtype.t vector option,
531 set = setConExtraArgs, destroy = destroy1, ...} =
532 Property.destGetSetOnce (Con.plist, Property.initConst NONE)
533 val {get = tyconExtraArgs: Tycon.t -> Xtype.t vector option,
534 set = setTyconExtraArgs, destroy = destroy2, ...} =
535 Property.destGetSetOnce (Tycon.plist, Property.initConst NONE)
536 val {destroy = destroy3, hom = loopTy} =
541 case tyconExtraArgs c of
543 | SOME ts' => Vector.concat [ts', ts]
548 Ctype.makeHom {con = con, var = Xtype.var}
552 ("Defunctorize.loopTy", Ctype.layout, Xtype.layout)
554 fun conTargs (c: Con.t, ts: Ctype.t vector): Xtype.t vector =
556 val ts = Vector.map (ts, loopTy)
558 case conExtraArgs c of
560 | SOME ts' => Vector.concat [ts', ts]
562 val {get = conTycon, set = setConTycon, ...} =
563 Property.getSetOnce (Con.plist,
564 Property.initRaise ("conTycon", Con.layout))
565 val {get = tyconCons: Tycon.t -> {con: Con.t,
566 hasArg: bool} vector,
567 set = setTyconCons, ...} =
568 Property.getSetOnce (Tycon.plist,
569 Property.initRaise ("tyconCons", Tycon.layout))
572 ("Defunctorize.setConTycon",
573 Con.layout, Tycon.layout, Unit.layout)
575 val datatypes = ref []
576 (* Process all the datatypes. *)
577 fun loopDec (d: Cdec.t) =
579 datatype z = datatype Cdec.t
584 val frees: Tyvar.t list ref = ref []
587 (dbs, fn {cons, tyvars, ...} =>
589 fun var (a: Tyvar.t): unit =
591 fun eq a' = Tyvar.equals (a, a')
593 if Vector.exists (tyvars, eq)
594 orelse List.exists (!frees, eq)
596 else List.push (frees, a)
599 Ctype.makeHom {con = fn _ => (),
602 Vector.foreach (cons, fn {arg, ...} =>
603 Option.app (arg, hom))
610 if List.isEmpty frees
614 val frees = Vector.fromList frees
615 val extra = Vector.map (frees, Xtype.var)
618 (dbs, fn {cons, tycon, tyvars} =>
620 val _ = setTyconExtraArgs (tycon, SOME extra)
623 (cons, fn {con, ...} =>
624 setConExtraArgs (con, SOME extra))
628 tyvars = Vector.concat [frees, tyvars]}
633 (dbs, fn {cons, tycon, tyvars} =>
637 Vector.map (cons, fn {arg, con} =>
639 hasArg = isSome arg}))
642 (cons, fn {arg, con} =>
643 (setConTycon (con, tycon)
644 ; {arg = Option.map (arg, loopTy),
648 if Tycon.equals (tycon, Tycon.reff)
651 List.push (datatypes, {cons = cons,
658 | Exception {con, ...} => setConTycon (con, Tycon.exn)
659 | Fun {decs, ...} => Vector.foreach (decs, loopLambda o #lambda)
660 | Val {rvbs, vbs, ...} =>
661 (Vector.foreach (rvbs, loopLambda o #lambda)
662 ; Vector.foreach (vbs, loopExp o #exp))
664 and loopExp (e: Cexp.t): unit =
666 datatype z = datatype Cexp.node
669 App (e, e') => (loopExp e; loopExp e')
670 | Case {rules, test, ...} =>
672 ; Vector.foreach (rules, loopExp o #exp))
675 | EnterLeave (e, _) => loopExp e
676 | Handle {handler, try, ...} => (loopExp handler; loopExp try)
677 | Lambda l => loopLambda l
678 | Let (ds, e) => (Vector.foreach (ds, loopDec); loopExp e)
679 | List es => Vector.foreach (es, loopExp)
680 | PrimApp {args, ...} => Vector.foreach (args, loopExp)
681 | Raise e => loopExp e
682 | Record r => Record.foreach (r, loopExp)
683 | Seq es => Vector.foreach (es, loopExp)
685 | Vector es => Vector.foreach (es, loopExp)
687 and loopLambda (l: Clambda.t): unit =
688 loopExp (#body (Clambda.dest l))
689 fun loopPat (p: Cpat.t): NestedPat.t =
691 val (p, t) = Cpat.dest p
693 datatype z = datatype Cpat.node
696 Con {arg, con, targs} =>
697 NestedPat.Con {arg = Option.map (arg, loopPat),
699 targs = conTargs (con, targs)}
701 NestedPat.Const {const = f (),
702 isChar = Ctype.isCharX t,
703 isInt = Ctype.isInt t}
704 | Layered (x, p) => NestedPat.Layered (x, loopPat p)
707 val targs = Vector.map (#2 (valOf (Ctype.deConOpt t)),
712 NestedPat.Con {arg = NONE,
716 NestedPat.Con {arg = SOME (NestedPat.tuple
719 NestedPat.make (np, t')))),
725 (SortedRecord.fromVector
727 (Ctype.deRecord t, fn (f, t: Ctype.t) =>
729 case Record.peek (r, f) of
730 NONE => NestedPat.make (NestedPat.Wild, loopTy t)
731 | SOME p => loopPat p))))
732 | Or ps => NestedPat.Or (Vector.map (ps, loopPat))
733 | Var x => NestedPat.Var x
734 | Vector ps => NestedPat.Vector (Vector.map (ps, loopPat))
735 | Wild => NestedPat.Wild
737 NestedPat.make (p, t')
739 val _ = Vector.foreach (decs, loopDec)
740 (* Now, do the actual defunctorization. *)
741 fun loopDec (d: Cdec.t, e: Xexp.t, et: Xtype.t): Xexp.t =
743 fun prefix (d: Xdec.t) =
744 Xexp.lett {decs = [d], body = e}
745 fun processLambdas v =
747 (Vector.rev v, fn {lambda, var} =>
749 val {arg, argType, body, bodyType, mayInline} =
752 {lambda = Xlambda.make {arg = arg,
754 body = Xexp.toExp body,
755 mayInline = mayInline},
756 ty = Xtype.arrow (argType, bodyType),
759 datatype z = datatype Cdec.t
763 | Exception {arg, con} =>
764 prefix (Xdec.Exception {arg = Option.map (arg, loopTy),
766 | Fun {decs, tyvars} =>
767 prefix (Xdec.Fun {decs = processLambdas decs,
769 | Val {matchDiags, rvbs, tyvars, vbs} =>
771 val tyvars = tyvars ()
775 (vbs, e, fn ({ctxt, exp, layPat, nest, pat, regionPat}, e) =>
777 fun patDec (p: NestedPat.t,
784 cases = Vector.new1 {exp = body,
785 layPat = SOME layPat,
787 regionPat = regionPat},
789 kind = ("declaration", "pattern"),
791 matchDiags = if mayWarn
793 else {nonexhaustiveExn = Control.Elaborate.DiagDI.Default,
794 nonexhaustive = Control.Elaborate.DiagEIW.Ignore,
795 redundant = Control.Elaborate.DiagEIW.Ignore},
796 noMatch = Cexp.RaiseBind,
798 test = (e, NestedPat.ty p),
799 tyconCons = tyconCons}
800 val isExpansive = Cexp.isExpansive exp
801 val (exp, expType) = loopExp exp
802 val pat = loopPat pat
803 fun vd (x: Var.t) = valDec (tyvars, x, exp, expType, e)
805 if Vector.isEmpty tyvars
806 then patDec (pat, exp, e, bodyType, true)
810 val x = Var.newNoname ()
817 {arg = Var.newNoname (),
818 argType = Xtype.unit,
824 Xtype.arrow (Xtype.unit, expType)
827 (t, Vector.map (tyvars, fn a =>
841 [Xdec.PolyVal {exp = thunk,
846 patDec (NestedPat.replaceTypes (pat, subst),
847 Xexp.lett {body = body, decs = decs},
851 case NestedPat.node pat of
852 NestedPat.Wild => vd (Var.newNoname ())
853 | NestedPat.Var x => vd x
855 (* Polymorphic pattern.
856 * val 'a Foo (y1, y2) = e
859 * val Foo (_, _) = x (* for match warnings *)
860 * val 'a y1 = case x of Foo (y1', _) => y1'
861 * val 'a y2 = case x of Foo (_, y2') => y2'
864 val x = Var.newNoname ()
866 val targs = Vector.map (tyvars, Xtype.var)
869 (NestedPat.varsAndTypes pat, e,
874 NestedPat.removeOthersReplace
875 (pat, {old = y, new = y'})
881 Xexp.var {targs = targs,
884 Xexp.monoVar (y', yt),
890 fun instantiatePat () =
892 val pat = NestedPat.removeVars pat
893 fun con (_, c, ts) = Xtype.con (c, ts)
897 Tyvar.equals (a, a')))
901 Xtype.makeHom {con = con,
904 NestedPat.replaceTypes
911 if NestedPat.isRefutable pat
915 Vector.map (tyvars, fn _ =>
917 val pat = instantiatePat ()
923 ty = NestedPat.ty pat,
931 valDec (tyvars, x, exp, expType, e)
935 if Vector.isEmpty rvbs
938 Xexp.lett {decs = [Xdec.Fun {decs = processLambdas rvbs,
943 and loopDecs (ds: Cdec.t vector, (e: Xexp.t, t: Xtype.t)): Xexp.t =
944 loopDecsList (Vector.toList ds, (e, t))
945 (* Convert vector->list to allow processed Cdecs to be GC'ed. *)
946 and loopDecsList (ds: Cdec.t list, (e: Xexp.t, t: Xtype.t)): Xexp.t =
947 List.foldr (ds, e, fn (d, e) => loopDec (d, e, t))
948 and loopExp (e: Cexp.t): Xexp.t * Xtype.t =
950 val (n, ty) = Cexp.dest e
952 fun conApp {arg, con, targs, ty} =
953 if Con.equals (con, Con.reff)
954 then Xexp.primApp {args = Vector.new1 arg,
958 else Xexp.conApp {arg = SOME arg,
962 datatype z = datatype Cexp.node
967 val (e2, _) = loopExp e2
973 targs = conTargs (con, targs),
977 func = #1 (loopExp e1),
980 | Case {ctxt, kind, nest, matchDiags, noMatch, region, rules, test, ...} =>
983 cases = Vector.map (rules, fn {exp, layPat, pat, regionPat} =>
984 {exp = #1 (loopExp exp),
987 regionPat = regionPat}),
991 matchDiags = matchDiags,
995 tyconCons = tyconCons}
996 | Con (con, targs) =>
998 val targs = conTargs (con, targs)
1000 case Xtype.deArrowOpt ty of
1002 Xexp.conApp {arg = NONE,
1006 | SOME (argType, bodyType) =>
1008 val arg = Var.newNoname ()
1014 {arg = Xexp.monoVar (arg, argType),
1018 bodyType = bodyType,
1026 if Xtype.equals (ty, Xtype.bool)
1033 | _ => Error.bug "Defunctorize.loopExp: Const:strange boolean constant")
1036 | EnterLeave (e, si) =>
1038 val (e, t) = loopExp e
1040 enterLeave (e, t, si)
1042 | Handle {catch = (x, t), handler, try} =>
1043 Xexp.handlee {catch = (x, loopTy t),
1044 handler = #1 (loopExp handler),
1045 try = #1 (loopExp try),
1047 | Lambda l => Xexp.lambda (loopLambda l)
1048 | Let (ds, e) => loopDecs (ds, loopExp e)
1051 (* Must evaluate list components left-to-right if there
1052 * is more than one expansive expression.
1055 Vector.fold (es, 0, fn (e, n) =>
1056 if Cexp.isExpansive e then n + 1 else n)
1058 Xexp.list (Vector.map (es, #1 o loopExp), ty,
1059 {forceLeftToRight = 2 <= numExpansive})
1061 | PrimApp {args, prim, targs} =>
1063 val args = Vector.map (args, #1 o loopExp)
1064 datatype z = datatype Prim.Name.t
1066 if (case Prim.name prim of
1067 Real_rndToReal (s1, s2) =>
1068 RealSize.equals (s1, s2)
1069 | String_toWord8Vector => true
1070 | Word_extdToWord (s1, s2, _) =>
1071 WordSize.equals (s1, s2)
1072 | Word8Vector_toString => true
1074 then Vector.first args
1076 Xexp.primApp {args = args,
1077 prim = Prim.map (prim, loopTy),
1078 targs = Vector.map (targs, loopTy),
1082 | Raise e => Xexp.raisee {exn = #1 (loopExp e), extend = true, ty = ty}
1084 (* The components of the record have to be evaluated left to
1085 * right as they appeared in the source program, but then
1086 * ordered according to sorted field name within the tuple.
1089 val fes = Record.toVector r
1092 (Vector.map (fes, #1 o loopExp o #2), fn es =>
1093 Xexp.tuple {exps = (sortByField
1095 (fes, es, fn ((f, _), e) => (f, e)))),
1098 | Seq es => Xexp.sequence (Vector.map (es, #1 o loopExp))
1099 | Var (var, targs) =>
1100 Xexp.var {targs = Vector.map (targs (), loopTy),
1104 Xexp.primApp {args = Vector.map (es, #1 o loopExp),
1106 targs = Vector.new1 (Xtype.deVector ty),
1111 and loopLambda (l: Clambda.t) =
1113 val {arg, argType, body, mayInline} = Clambda.dest l
1114 val (body, bodyType) = loopExp body
1117 argType = loopTy argType,
1119 bodyType = bodyType,
1120 mayInline = mayInline}
1122 val body = Xexp.toExp (loopDecs (decs, (Xexp.unit (), Xtype.unit)))
1123 val _ = showMatchDiagnostics ()
1124 val _ = (destroy1 (); destroy2 (); destroy3 ())
1126 Xml.Program.T {body = body,
1127 datatypes = Vector.fromList (!datatypes),