Skip to content

Instantly share code, notes, and snippets.

@ppetr

ppetr/Main.dump-simpl

Created October 28, 2012 05:23
Show Gist options
  • Save ppetr/3967720 to your computer and use it in GitHub Desktop.
Save ppetr/3967720 to your computer and use it in GitHub Desktop.
Download ZIP
Is it possible to make GHC optimize (deforest) generic functions such as catamorphisms?
Raw
Main.dump-simpl
Result size = 325
Main.$fFunctorTreeT_$cfmap
:: forall a_ajJ b_ajK.
(a_ajJ -> b_ajK) -> Main.TreeT a_ajJ -> Main.TreeT b_ajK
[GblId,
Arity=2,
Caf=NoCafRefs,
Str=DmdType LS,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [120 30] 70 130}]
Main.$fFunctorTreeT_$cfmap =
\ (@ a_axE)
(@ b_axF)
(f_aam :: a_axE -> b_axF)
(ds_dyQ :: Main.TreeT a_axE) ->
case ds_dyQ of _ {
Main.Leaf -> Main.Leaf @ b_axF;
Main.Tree l_aao r_aap ->
Main.Tree @ b_axF (f_aam l_aao) (f_aam r_aap)
}
Main.$fFunctorTreeT_$c<$
:: forall a_ayF b_ayG.
a_ayF -> Main.TreeT b_ayG -> Main.TreeT a_ayF
[GblId,
Arity=2,
Caf=NoCafRefs,
Str=DmdType LS,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=2, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.$fFunctorTreeT_$c<$ =
\ (@ a_az9)
(@ b_aza)
(x_azb :: a_az9)
(eta_B1 :: Main.TreeT b_aza) ->
case eta_B1 of _ {
Main.Leaf -> Main.Leaf @ a_az9;
Main.Tree l_aao r_aap -> Main.Tree @ a_az9 x_azb x_azb
}
Main.$fFunctorTreeT [InlPrag=[ALWAYS] CONLIKE]
:: GHC.Base.Functor Main.TreeT
[GblId[DFunId],
Caf=NoCafRefs,
Str=DmdType m,
Unf=DFun(arity=0) GHC.Base.D:Functor [Main.$fFunctorTreeT_$cfmap,
Main.$fFunctorTreeT_$c<$]]
Main.$fFunctorTreeT =
GHC.Base.D:Functor
@ Main.TreeT Main.$fFunctorTreeT_$cfmap Main.$fFunctorTreeT_$c<$
Main.unfix1
:: forall (f_aay :: * -> *). Main.Fix f_aay -> Main.Fix f_aay
[GblId,
Arity=1,
Caf=NoCafRefs,
Str=DmdType S,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.unfix1 =
\ (@ f_aay::* -> *) (ds_dyO :: Main.Fix f_aay) -> ds_dyO
Main.unfix
:: forall (f_aab :: * -> *).
Main.Fix f_aab -> f_aab (Main.Fix f_aab)
[GblId[[RecSel]],
Arity=1,
Caf=NoCafRefs,
Str=DmdType S,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.unfix =
Main.unfix1
`cast` (forall (f_aay :: * -> *).
<Main.Fix f_aay> -> Main.NTCo:Fix <f_aay>
:: (forall (f_aay :: * -> *). Main.Fix f_aay -> Main.Fix f_aay)
~#
(forall (f_aay :: * -> *).
Main.Fix f_aay -> f_aay (Main.Fix f_aay)))
Main.catam_$scatam [InlPrag=INLINE (sat-args=1)]
:: forall a_ajC.
(Main.TreeT a_ajC -> a_ajC) -> Main.Fix Main.TreeT -> a_ajC
[GblId,
Arity=2,
Caf=NoCafRefs,
Str=DmdType C(S)L,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
Tmpl= \ (@ a_ajC)
(eta_B1 [Occ=OnceL!] :: Main.TreeT a_ajC -> a_ajC) ->
letrec {
g_sAi [Occ=LoopBreaker] :: Main.Fix Main.TreeT -> a_ajC
[LclId, Arity=1]
g_sAi =
\ (x_az2 [Occ=Once] :: Main.Fix Main.TreeT) ->
eta_B1
(Main.$fFunctorTreeT_$cfmap
@ (Main.Fix Main.TreeT)
@ a_ajC
g_sAi
(Main.unfix @ Main.TreeT x_az2)); } in
g_sAi}]
Main.catam_$scatam =
\ (@ a_ajC)
(eta_B1 :: Main.TreeT a_ajC -> a_ajC)
(eta1_X2 :: Main.Fix Main.TreeT) ->
eta_B1
(letrec {
a_sAg [Occ=LoopBreaker]
:: Main.TreeT (Main.Fix Main.TreeT) -> Main.TreeT a_ajC
[LclId, Arity=1, Str=DmdType S]
a_sAg =
\ (ds_dyQ :: Main.TreeT (Main.Fix Main.TreeT)) ->
case ds_dyQ of _ {
Main.Leaf -> Main.Leaf @ a_ajC;
Main.Tree l_aao r_aap ->
Main.Tree
@ a_ajC
(eta_B1
(a_sAg
(l_aao
`cast` (Main.NTCo:Fix <Main.TreeT>
:: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)))))
(eta_B1
(a_sAg
(r_aap
`cast` (Main.NTCo:Fix <Main.TreeT>
:: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)))))
}; } in
a_sAg
(eta1_X2
`cast` (Main.NTCo:Fix <Main.TreeT>
:: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))))
Main.catam [InlPrag=INLINE (sat-args=1)]
:: forall (f_aad :: * -> *) a_aae.
GHC.Base.Functor f_aad =>
(f_aad a_aae -> a_aae) -> Main.Fix f_aad -> a_aae
[GblId,
Arity=2,
Caf=NoCafRefs,
Str=DmdType LL,
Unf=Unf{Src=InlineStable, TopLvl=True, Arity=2, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=False,boring_ok=False)
Tmpl= \ (@ f_ajB::* -> *)
(@ a_ajC)
($dFunctor_ajD [Occ=Once] :: GHC.Base.Functor f_ajB)
(f_aaf [Occ=OnceL!] :: f_ajB a_ajC -> a_ajC) ->
letrec {
f1_Xzl [Occ=OnceL!] :: f_ajB (Main.Fix f_ajB) -> f_ajB a_ajC
[LclId]
f1_Xzl =
GHC.Base.fmap
@ f_ajB $dFunctor_ajD @ (Main.Fix f_ajB) @ a_ajC g_Xk8;
g_Xk8 [Occ=LoopBreaker] :: Main.Fix f_ajB -> a_ajC
[LclId, Arity=1]
g_Xk8 =
\ (x_Xzr [Occ=Once] :: Main.Fix f_ajB) ->
f_aaf (f1_Xzl (Main.unfix @ f_ajB x_Xzr)); } in
g_Xk8}]
Main.catam =
\ (@ f_ajB::* -> *)
(@ a_ajC)
($dFunctor_ajD :: GHC.Base.Functor f_ajB)
(eta_B1 :: f_ajB a_ajC -> a_ajC) ->
letrec {
a_sAa :: f_ajB (Main.Fix f_ajB) -> f_ajB a_ajC
[LclId, Str=DmdType]
a_sAa =
GHC.Base.fmap
@ f_ajB $dFunctor_ajD @ (Main.Fix f_ajB) @ a_ajC g_sAc;
g_sAc [Occ=LoopBreaker] :: Main.Fix f_ajB -> a_ajC
[LclId, Arity=1, Str=DmdType L]
g_sAc =
\ (x_az2 :: Main.Fix f_ajB) ->
eta_B1
(a_sAa
(x_az2
`cast` (Main.NTCo:Fix <f_ajB>
:: Main.Fix f_ajB ~# f_ajB (Main.Fix f_ajB)))); } in
g_sAc
Rec {
Main.$wdepth1 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int#
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S]
Main.$wdepth1 =
\ (w_s1RI :: Main.Tree) ->
case w_s1RI
`cast` (Main.NTCo:Fix <Main.TreeT>
:: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
of _ {
Main.Leaf -> 0;
Main.Tree l_aao r_aap ->
case Main.$wdepth1 l_aao of ww_s1RL { __DEFAULT ->
case Main.$wdepth1 r_aap of ww1_X1Sn { __DEFAULT ->
case GHC.Prim.<=# ww_s1RL ww1_X1Sn of _ {
GHC.Types.False -> ww_s1RL;
GHC.Types.True -> ww1_X1Sn
}
}
}
}
end Rec }
Main.depth1 [InlPrag=INLINE[0]] :: Main.Tree -> GHC.Types.Int
[GblId,
Arity=1,
Caf=NoCafRefs,
Str=DmdType Sm,
Unf=Unf{Src=Worker=Main.$wdepth1, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Tmpl= \ (w_s1RI [Occ=Once] :: Main.Tree) ->
case Main.$wdepth1 w_s1RI of ww_s1RL { __DEFAULT ->
GHC.Types.I# ww_s1RL
}}]
Main.depth1 =
\ (w_s1RI :: Main.Tree) ->
case Main.$wdepth1 w_s1RI of ww_s1RL { __DEFAULT ->
GHC.Types.I# ww_s1RL
}
Rec {
Main.$wdepth2 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int#
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S]
Main.$wdepth2 =
\ (w_s1RO :: Main.Tree) ->
case w_s1RO
`cast` (Main.NTCo:Fix <Main.TreeT>
:: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
of _ {
Main.Leaf -> 0;
Main.Tree l_aak r_aal ->
case Main.$wdepth2 l_aak of ww_s1RR { __DEFAULT ->
case Main.$wdepth2 r_aal of ww1_X1Sw { __DEFAULT ->
case GHC.Prim.<=# ww_s1RR ww1_X1Sw of _ {
GHC.Types.False -> ww_s1RR;
GHC.Types.True -> ww1_X1Sw
}
}
}
}
end Rec }
Main.depth2 [InlPrag=INLINE[0]] :: Main.Tree -> GHC.Types.Int
[GblId,
Arity=1,
Caf=NoCafRefs,
Str=DmdType Sm,
Unf=Unf{Src=Worker=Main.$wdepth2, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=False)
Tmpl= \ (w_s1RO [Occ=Once] :: Main.Tree) ->
case Main.$wdepth2 w_s1RO of ww_s1RR { __DEFAULT ->
GHC.Types.I# ww_s1RR
}}]
Main.depth2 =
\ (w_s1RO :: Main.Tree) ->
case Main.$wdepth2 w_s1RO of ww_s1RR { __DEFAULT ->
GHC.Types.I# ww_s1RR
}
Main.main2 :: GHC.Base.String
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 415 480}]
Main.main2 =
case Main.$wdepth2
((Main.Leaf @ (Main.Fix Main.TreeT))
`cast` (Sym (Main.NTCo:Fix <Main.TreeT>)
:: Main.TreeT (Main.Fix Main.TreeT) ~# Main.Fix Main.TreeT))
of ww_s1RR { __DEFAULT ->
case GHC.Prim.<# ww_s1RR 0 of _ {
GHC.Types.False ->
case GHC.Prim.<# ww_s1RR 0 of _ {
GHC.Types.False ->
GHC.Show.shows_itos' ww_s1RR (GHC.Types.[] @ GHC.Types.Char);
GHC.Types.True ->
case ww_s1RR of wild2_a1S9 {
__DEFAULT ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
(GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
(-2147483648) ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
}
};
GHC.Types.True ->
case GHC.Prim.<# ww_s1RR 0 of _ {
GHC.Types.False ->
GHC.Show.shows_itos' ww_s1RR (GHC.Types.[] @ GHC.Types.Char);
GHC.Types.True ->
case ww_s1RR of wild2_a1S9 {
__DEFAULT ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
(GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
(-2147483648) ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
}
}
}
}
Main.main3 :: GHC.Base.String
[GblId,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
ConLike=False, Cheap=False, Expandable=False,
Guidance=IF_ARGS [] 415 480}]
Main.main3 =
case Main.$wdepth1
((Main.Leaf @ (Main.Fix Main.TreeT))
`cast` (Sym (Main.NTCo:Fix <Main.TreeT>)
:: Main.TreeT (Main.Fix Main.TreeT) ~# Main.Fix Main.TreeT))
of ww_s1RL { __DEFAULT ->
case GHC.Prim.<# ww_s1RL 0 of _ {
GHC.Types.False ->
case GHC.Prim.<# ww_s1RL 0 of _ {
GHC.Types.False ->
GHC.Show.shows_itos' ww_s1RL (GHC.Types.[] @ GHC.Types.Char);
GHC.Types.True ->
case ww_s1RL of wild2_a1S9 {
__DEFAULT ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
(GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
(-2147483648) ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
}
};
GHC.Types.True ->
case GHC.Prim.<# ww_s1RL 0 of _ {
GHC.Types.False ->
GHC.Show.shows_itos' ww_s1RL (GHC.Types.[] @ GHC.Types.Char);
GHC.Types.True ->
case ww_s1RL of wild2_a1S9 {
__DEFAULT ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
(GHC.Prim.negateInt# wild2_a1S9) (GHC.Types.[] @ GHC.Types.Char));
(-2147483648) ->
GHC.Types.:
@ GHC.Types.Char
GHC.Show.shows3
(GHC.Show.shows_itos'
214748364 (GHC.Show.shows_itos' 8 (GHC.Types.[] @ GHC.Types.Char)))
}
}
}
}
Main.main1
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[GblId,
Arity=1,
Str=DmdType L,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 110 0}]
Main.main1 =
\ (eta_B1 :: GHC.Prim.State# GHC.Prim.RealWorld) ->
case GHC.IO.Handle.Text.hPutStr2
GHC.IO.Handle.FD.stdout Main.main3 GHC.Types.True eta_B1
of _ { (# new_s_aUc, _ #) ->
GHC.IO.Handle.Text.hPutStr2
GHC.IO.Handle.FD.stdout Main.main2 GHC.Types.True new_s_aUc
}
Main.main :: GHC.Types.IO ()
[GblId,
Arity=1,
Str=DmdType L,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
Main.main =
Main.main1
`cast` (Sym (GHC.Types.NTCo:IO <()>)
:: (GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
~#
GHC.Types.IO ())
Main.main4
:: GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)
[GblId,
Arity=1,
Str=DmdType L,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=IF_ARGS [0] 30 0}]
Main.main4 =
\ (eta_Xr :: GHC.Prim.State# GHC.Prim.RealWorld) ->
GHC.TopHandler.runMainIO1
@ ()
(Main.main1
`cast` (Sym (GHC.Types.NTCo:IO <()>)
:: (GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
~#
GHC.Types.IO ()))
eta_Xr
:Main.main :: GHC.Types.IO ()
[GblId,
Arity=1,
Str=DmdType L,
Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
ConLike=True, Cheap=True, Expandable=True,
Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
:Main.main =
Main.main4
`cast` (Sym (GHC.Types.NTCo:IO <()>)
:: (GHC.Prim.State# GHC.Prim.RealWorld
-> (# GHC.Prim.State# GHC.Prim.RealWorld, () #))
~#
GHC.Types.IO ())
------ Local rules for imported ids --------
"SPEC Main.catam [Main.TreeT]" [ALWAYS]
forall (@ a_ajC) ($dFunctor_sAv :: GHC.Base.Functor Main.TreeT).
Main.catam @ Main.TreeT @ a_ajC $dFunctor_sAv
= Main.catam_$scatam @ a_ajC
Raw
Main.hs
-- Is it possible to make GHC optimize (deforest) generic functions such as catamorphisms?
-- http://stackoverflow.com/q/13099203/1333025
module Main where
data TreeT r = Leaf | Tree r r
instance Functor TreeT where
fmap f Leaf = Leaf
fmap f (Tree l r) = Tree (f l) (f r)
newtype Fix f = Fix { unfix :: f (Fix f) }
type Tree = Fix TreeT
{-# INLINE catam #-}
catam :: (Functor f) => (f a -> a) -> (Fix f -> a)
catam f = let g = f . fmap g . unfix
in g
depth1 :: Tree -> Int
depth1 = catam g
where
g Leaf = 0
g (Tree l r) = max l r
depth2 :: Tree -> Int
depth2 (Fix Leaf) = 0
depth2 (Fix (Tree l r)) = max (depth2 l) (depth2 r)
main :: IO ()
main = do
print $ depth1 (Fix Leaf)
print $ depth2 (Fix Leaf)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment