1 (* Copyright 1999,2004,2007,2010-2012,2014 Stefan Monnier <monnier@gnu.org> *)
3 (* sml-mode here treats the second `=' as an equal op because it
4 * thinks it's seeing something like "... type t = (s.t = ...)". FIXME! *)
5 functor foo (structure s : S) where type t = s.t =
61 = Attributes of string list
63 sharing type node' = node
67 functor DoWrap1(type node) : S = struct
75 = Let of varpat_t list * rhs_t * exp_t
76 | Do of simpleexp_t * exp_t
77 | FunExp of fundef_t list * exp_t
78 | ContExp of BomId.t * varpat_t list option * exp_t * exp_t
79 | If of simpleexp_t * exp_t * exp_t
80 | Case of simpleexp_t * caserule_t list
81 | Typecase of TyParam.t * tycaserule_t list
82 | Apply of LongValueId.t * simpleexp_t list option * simpleexp_t list option
83 | Throw of BomId.t * tyargs_t option * simpleexp_t list option
84 | Return of simpleexp_t list option
87 | Simple of simpleexp_t
89 withtype type_t = type_node Wrap.t
90 and tyargs_t = tyargs_node Wrap.t
92 functor DoWrap(type node) : sig
95 sharing type node' = node
107 val tut = fn (x,y) z y e r =>
109 val tut = fn (x,y) => fn z y => fn e r =>
119 val x = 1 in val x = x end
121 local val x = 1 in val x = x end
122 local val x = 1 in val x = x end
123 local val x = 1 in val x = x end (* fixindent *)
124 local val x = 1 in val x = x end
136 (* From "Christopher Dutchyn" <cdutchyn@cs.ubc.ca> *)
138 (* This is actually not valid SML anyway. *)
146 (* Testing obedience to user overrides: *)
147 x := 3; (* fixindent *)
164 datatype foo = FOO | BAR of baz
165 and baz = BAZ | QUUX of foo
174 and baz = BAZ (* fixindent *)
178 datatype foo = datatype M.foo
181 signature S = S' where type foo = int
186 , let val x = f 42 in g (x,x,44) end
191 let val x = f 42 in g (x,x,44) end
197 let val x = f 42 in g (x,x,44) end
201 , let val x = f 42 in g (x,x,44) end
202 , foldl (fn ((p,q),s) => g (p,q,Vector.length q) ^ ":" ^ s)
203 "" (Beeblebrox.masterCountList mlist2)
204 , if null mlist2 then ";" else ""
207 fun foo (true::rest) = 1 + 2 * foo rest
209 = let val _ = 1 in 2 end
222 then 2 (* Could also be indented by a basic offset. *)
231 F.APP(F.VAR fl, OU.filter filt vs)
308 structure Foo = struct
312 structure Foo = struct val x = 1
317 type flint = FLINT.prog
318 val split: flint -> flint * flint option
321 structure FSplit :> FSPLIT =
326 structure S = IntRedBlackSet
327 structure M = FLINTIntMap
329 structure OU = OptUtils
330 structure FU = FlintUtil
331 structure LT = LtyExtern
332 structure PO = PrimOp
333 structure PP = PPFlint
334 structure CTRL = FLINT_Control
337 val say = Control_Print.say
338 fun bug msg = ErrorMsg.impossible ("FSplit: "^msg)
339 fun buglexp (msg,le) = (say "\n"; PP.printLexp le; say " "; bug msg)
340 fun bugval (msg,v) = (say "\n"; PP.printSval v; say " "; bug msg)
341 fun assert p = if p then () else bug ("assertion failed")
344 val mklv = LambdaVar.mkLvar
345 val cplv = LambdaVar.dupLvar
347 fun S_rmv(x, s) = S.delete(s, x) handle NotFound => s
349 fun addv (s,F.VAR lv) = S.add(s, lv)
351 fun addvs (s,vs) = foldl (fn (v,s) => addv(s, v)) s vs
352 fun rmvs (s,lvs) = foldl (fn (l,s) => S_rmv(l, s)) s lvs
356 fun split (fdec as (fk,f,args,body)) = let
357 val {getLty,addLty,...} = Recover.recover (fdec, false)
359 val m = Intmap.new(64, Unknown)
360 fun addpurefun f = Intmap.add m (f, false)
361 fun funeffect f = (Intmap.map m f) handle Uknown => true
363 (* sexp: env -> lexp -> (leE, leI, fvI, leRet)
364 * - env: IntSetF.set current environment
365 * - lexp: lexp expression to split
366 * - leRet: lexp the core return expression of lexp
367 * - leE: lexp -> lexp recursively split lexp: leE leRet == lexp
368 * - leI: lexp option inlinable part of lexp (if any)
369 * - fvI: IntSetF.set free variables of leI: FU.freevars leI == fvI
371 * sexp splits the lexp into an expansive part and an inlinable part.
372 * The inlinable part is guaranteed to be side-effect free.
373 * The expansive part doesn't bother to eliminate unused copies of
374 * elements copied to the inlinable part.
375 * If the inlinable part cannot be constructed, leI is set to F.RET[].
376 * This implies that fvI == S.empty, which in turn prevents us from
377 * mistakenly adding anything to leI.
379 fun sexp env lexp = (* fixindent *)
381 (* non-side effecting binds are copied to leI if exported *)
382 fun let1 (le,lewrap,lv,vs,effect) =
383 let val (leE,leI,fvI,leRet) = sexp (S.add(env, lv)) le
384 val leE = lewrap o leE
385 in if effect orelse not (S.member(fvI, lv))
386 then (leE, leI, fvI, leRet)
387 else (leE, lewrap leI, addvs(S_rmv(lv, fvI), vs), leRet)
391 (* we can completely move both RET and TAPP to the I part *)
392 of F.RECORD (rk,vs,lv,le as F.RET [F.VAR lv']) =>
394 then (fn e => e, lexp, addvs(S.empty, vs), lexp)
395 else (fn e => e, le, S.singleton lv', le)
397 (fn e => e, lexp, addvs(S.empty, vs), lexp)
398 | F.TAPP (F.VAR tf,tycs) =>
399 (fn e => e, lexp, S.singleton tf, lexp)
401 (* recursive splittable lexps *)
402 | F.FIX (fdecs,le) => sfix env (fdecs, le)
403 | F.TFN (tfdec,le) => stfn env (tfdec, le)
406 | F.CON (dc,tycs,v,lv,le) =>
407 let1(le, fn e => F.CON(dc, tycs, v, lv, e), lv, [v], false)
408 | F.RECORD (rk,vs,lv,le) =>
409 let1(le, fn e => F.RECORD(rk, vs, lv, e), lv, vs, false)
410 | F.SELECT (v,i,lv,le) =>
411 let1(le, fn e => F.SELECT(v, i, lv, e), lv, [v], false)
412 | F.PRIMOP (po,vs,lv,le) =>
413 let1(le, fn e => F.PRIMOP(po, vs, lv, e), lv, vs, PO.effect(#2 po))
415 (* IMPROVEME: lvs should not be restricted to [lv] *)
416 | F.LET(lvs as [lv],body as F.TAPP (v,tycs),le) =>
417 let1(le, fn e => F.LET(lvs, body, e), lv, [v], false)
418 | F.LET (lvs as [lv],body as F.APP (v as F.VAR f,vs),le) =>
419 let1(le, fn e => F.LET(lvs, body, e), lv, v::vs, funeffect f)
421 | F.SWITCH (v,ac,[(dc as F.DATAcon(_,_,lv),le)],NONE) =>
422 let1(le, fn e => F.SWITCH(v, ac, [(dc, e)], NONE), lv, [v], false)
424 | F.LET (lvs,body,le) =>
425 let val (leE,leI,fvI,leRet) = sexp (S.union(S.addList(S.empty, lvs), env)) le
426 in (fn e => F.LET(lvs, body, leE e), leI, fvI, leRet)
429 (* useless sophistication *)
430 | F.APP (F.VAR f,args) =>
432 then (fn e => e, F.RET[], S.empty, lexp)
433 else (fn e => e, lexp, addvs(S.singleton f, args), lexp)
435 (* other non-binding lexps result in unsplittable functions *)
436 | (F.APP _ | F.TAPP _) => bug "strange (T)APP"
437 | (F.SWITCH _ | F.RAISE _ | F.BRANCH _ | F.HANDLE _) =>
438 (fn e => e, F.RET[], S.empty, lexp)
441 (* Functions definitions fall into the following categories:
442 * - inlinable: if exported, copy to leI
443 * - (mutually) recursive: don't bother
444 * - non-inlinable non-recursive: split recursively *)
445 and sfix env (fdecs,le) =
446 let val nenv = S.union(S.addList(S.empty, map #2 fdecs), env)
447 val (leE,leI,fvI,leRet) = sexp nenv le
448 val nleE = fn e => F.FIX(fdecs, leE e)
450 of [({inline=inl as (F.IH_ALWAYS | F.IH_MAYBE _),...},f,args,body)] =>
451 let val min = case inl of F.IH_MAYBE(n,_) => n | _ => 0
452 in if not(S.member(fvI, f)) orelse min > !CTRL.splitThreshold
453 then (nleE, leI, fvI, leRet)
454 else (nleE, F.FIX(fdecs, leI),
455 rmvs(S.union(fvI, FU.freevars body),
459 | [fdec as (fk as {cconv=F.CC_FCT,...},_,_,_)] =>
460 sfdec env (leE,leI,fvI,leRet) fdec
462 | _ => (nleE, leI, fvI, leRet)
465 and sfdec env (leE,leI,fvI,leRet) (fk,f,args,body) =
466 let val benv = S.union(S.addList(S.empty, map #1 args), env)
467 val (bodyE,bodyI,fvbI,bodyRet) = sexp benv body
470 (fn e => F.FIX([(fk, f, args, bodyE bodyRet)], e),
473 let val fvbIs = S.listItems(S.difference(fvbI, benv))
474 val (nfk,fkE) = OU.fk_wrap(fk, NONE)
478 val fErets = (map F.VAR fvbIs)
479 val bodyE = bodyE(F.RET fErets)
481 val bodyE = bodyE(F.RECORD(F.RK_STRUCT, map F.VAR fvbIs,
482 tmp, F.RET[F.VAR tmp])) *)
483 val fdecE = (fkE, fE, args, bodyE)
484 val fElty = LT.ltc_fct(map #2 args, map getLty fErets)
485 val _ = addLty(fE, fElty)
488 val fkI = {inline=F.IH_ALWAYS, cconv=F.CC_FCT,
489 known=true, isrec=NONE}
491 (map (fn lv => (lv, getLty(F.VAR lv))) fvbIs) @ args
492 val fdecI as (_,fI,_,_) = FU.copyfdec(fkI,f,argsI,bodyI)
493 val _ = addpurefun fI
496 val nargs = map (fn (v,t) => (cplv v, t)) args
497 val argsv = map (fn (v,t) => F.VAR v) nargs
499 let val lvs = map cplv fvbIs
500 in F.LET(lvs, F.APP(F.VAR fE, argsv),
501 F.APP(F.VAR fI, (map F.VAR lvs)@argsv))
503 (* let val lv = mklv()
504 in F.LET([lv], F.APP(F.VAR fE, argsv),
505 F.APP(F.VAR fI, (F.VAR lv)::argsv))
507 val nfdec = (nfk, f, nargs, nbody)
509 (* and now, for the whole F.FIX *)
511 F.FIX([fdecE], F.FIX([fdecI], F.FIX([nfdec], leE e)))
513 in if not(S.member(fvI, f)) then (nleE, leI, fvI, leRet)
515 F.FIX([fdecI], F.FIX([nfdec], leI)),
516 S.add(S.union(S_rmv(f, fvI), S.intersection(env, fvbI)), fE),
521 (* TFNs are kinda like FIX except there's no recursion *)
522 and stfn env (tfdec as (tfk,tf,args,body),le) =
523 let val (bodyE,bodyI,fvbI,bodyRet) =
524 if #inline tfk = F.IH_ALWAYS
525 then (fn e => body, body, FU.freevars body, body)
527 val nenv = S.add(env, tf)
528 val (leE,leI,fvI,leRet) = sexp nenv le
529 in case (bodyI, S.listItems(S.difference(fvbI, env)))
530 of ((F.RET _ | F.RECORD(_,_,_,F.RET _)),_) =>
532 (fn e => F.TFN((tfk, tf, args, bodyE bodyRet), leE e),
535 (* everything was split out *)
536 let val ntfdec = ({inline=F.IH_ALWAYS}, tf, args, bodyE bodyRet)
537 val nlE = fn e => F.TFN(ntfdec, leE e)
538 in if not(S.member(fvI, tf)) then (nlE, leI, fvI, leRet)
539 else (nlE, F.TFN(ntfdec, leI),
540 S_rmv(tf, S.union(fvI, fvbI)), leRet)
545 val tfEvs = map F.VAR fvbIs
546 val bodyE = bodyE(F.RET tfEvs)
547 val tfElty = LT.lt_nvpoly(args, map getLty tfEvs)
548 val _ = addLty(tfE, tfElty)
551 val tfkI = {inline=F.IH_ALWAYS}
552 val argsI = map (fn (v,k) => (cplv v, k)) args
553 (* val tmap = ListPair.map (fn (a1,a2) =>
554 * (#1 a1, LT.tcc_nvar(#1 a2)))
556 val bodyI = FU.copy tmap M.empty
557 (F.LET(fvbIs, F.TAPP(F.VAR tfE, map #2 tmap),
561 F.TFN((tfk, tfE, args, bodyE),
562 F.TFN((tfkI, tf, argsI, bodyI), leE e))
564 in if not(S.member(fvI, tf)) then (nleE, leI, fvI, leRet)
566 F.TFN((tfkI, tf, argsI, bodyI), leI),
567 S.add(S.union(S_rmv(tf, fvI), S.intersection(env, fvbI)), tfE),
572 (* here, we use B-decomposition, so the args should not be
573 * considered as being in scope *)
574 val (bodyE,bodyI,fvbI,bodyRet) = sexp S.empty body
575 in case (bodyI, bodyRet)
576 of (F.RET _,_) => ((fk, f, args, bodyE bodyRet), NONE)
577 | (_,F.RECORD (rk,vs,lv,F.RET[lv'])) =>
578 let val fvbIs = S.listItems fvbI
581 val bodyE = bodyE(F.RECORD(rk, vs@(map F.VAR fvbIs), lv, F.RET[lv']))
582 val fdecE as (_,fE,_,_) = (fk, cplv f, args, bodyE)
586 val argLtys = (map getLty vs) @ (map (getLty o F.VAR) fvbIs)
587 val argsI = [(argI, LT.ltc_str argLtys)]
588 val (_,bodyI) = foldl (fn (lv,(n,le)) =>
589 (n+1, F.SELECT(F.VAR argI, n, lv, le)))
590 (length vs, bodyI) fvbIs
591 val fdecI as (_,fI,_,_) = FU.copyfdec (fk, f, argsI, bodyI)
593 val nargs = map (fn (v,t) => (cplv v, t)) args
600 F.APP(F.VAR fE, map (F.VAR o #1) nargs),
601 F.APP(F.VAR fI, [F.VAR argI]))))),
605 | _ => (fdec, NONE) (* sorry, can't do that *)
606 (* (PPFlint.printLexp bodyRet; bug "couldn't find the returned record") *)