Hi,
I attach a piece of code: it's part of my thesis, attempts to turn
(strict) functions to catamorphisms (see the comment in the code). It
compiles just fine with core lint and debug on, but when I add the call
to cheapSimplify it produces a runtime error:
[hsc: no threads to run: infinite loop or deadlock?]
The funny thing is of course that the result is not even used, only
printed with trace. Without the call to cheapSimplify it prints whatever
it is expected to print. I did not tinker with simplExpr (which is
called by cheapSimplify) or any other part of the compiler only added to
it. I am using the original -- from someone's RPM -- 4.06 under SuSe
6.3. If you need all the code (it's three more files 2-300 lines each)
to reproduce the error I'm happy to send it.
Any ideas?
Thanks,
Laszlo
\begin{code}
module Cataify ( cataify ) where
#include "HsVersions.h"
import CoreSyn
import CoreUtils ( coreExprType )
import CoreUnfold ( certainlySmallEnoughToInline, calcUnfoldingGuidance )
import CmdLineOpts ( opt_D_dump_cataified, opt_UF_CreationThreshold
, SwitchResult(..), SimplifierSwitch(..) )
import Id ( getInlinePragma, mkVanillaId, setInlinePragma )
import IdInfo ( InlinePragInfo(..) )
import TyCon ( TyCon, tyConTyVars )
import DataCon ( dataConArgTys, dataConName, DataCon )
import Simplify ( simplExpr )
import SimplMonad ( initSmpl, thenSmpl, mapSmpl, returnSmpl )
import CoreLint ( beginPass, endPass )
import OccName ( mkSrcVarOcc )
import Name ( mkDerivedName, getOccString )
import VarSet ( VarSet, emptyVarSet, mkVarSet )
import FastString ( mkFastString )
import List ( partition )
import Util ( only, sortLt )
import WFUtil
import Outputable
\end{code}
\begin{code}
cataify :: UniqSupply -> [CoreBind] -> IO [CoreBind]
cataify us binds
= do {
beginPass "Cataify";
let { binds' = initUs_ us $
mapUs (walkBind (fusible_tcs, cataids, mapids)) others `thenUs`
\ others' ->
returnUs (concat others') };
-- endPass "Cataify" opt_D_dump_cataified (cbs ++ binds');
return ([Rec . flattenBinds $ (catas ++ binds')]);
}
where
(catas, others) = partition (isCata . getFirstBdr) binds
-- tycon is fusible *iff* there is a cata for it
fusible_tcs = map (sortLt sortPredForTyCons . map tyConOfCataOrMap . bindersOf)
$ catas
cataids = bindersOfBinds catas
mapids = bindersOfBinds . filter (isMap . getFirstBdr) $ others
\end{code}
f :: \/a .T t -> v
f = /\ a \ t v. e
=>
f_1 = /\ a \ z_1 .. z_n \ v.(\t.e) (C1 tyargs x_1 ... x_nm)
...
f_n = /\ a \ z_1 .. z_n \ v.(\t.e) (Cn tyargs x_1 ... x_nm)
f is split into as many functions as constructors of T has.
v denotes an arbitrary number of arguments
x_1...x_n are appropriately typed fresh variables
z_1...z_n ditto, but their types are 'abstractified' (abstractTys)
we can't generate the zs (new binders -- rhs of rules) here as we
don't have all the bindings in a mutually recursive group i.e. we
don't know how many rho's we need.
So we do
f_1 = /\ a \ v.(\t.e) (C1 tyargs x_1 ... x_nm)
!!! zs need to be inserted between the type binders and v !!!
\begin{code}
cataifySplit :: ([[TyCon]], [Id], [Id]) -> [ (Id, CoreExpr) ] -> UniqSM [ CoreBind ]
cataifySplit (ftcs, _, _) binds__
-- never_inline needs to be put back, but right now the
-- buildified stuff is marked as never inline
| any null argss__ -- all of them are functions
{-|| never_inline fn_id-}
|| any (not . maybeFusible (concat ftcs) . head) argss__ -- all the first args are
|fusible
|| any null bdrss__ -- we can get the arguments
-- FIX ME: add that the number of functions in the mut rec group is
-- exactly the same as the number of mut rec tycons. We don't
-- know what to do with the extra functions.
= trace (showSDoc (hcat [text "Failed: " <> ppr bdrs__ <+> ppr argss__])) $
returnUs [Rec binds__]
| otherwise -- Do the business
-- ASSUMPTION: the entire group is quantified over the same
-- number of type variables
= getUniquesUs (length . takeWhile (not . isId) $ (head bdrss)) `thenUs` \ tv_uniqs
->
getUs `thenUs` \ supply
->
let
tvs = map myMkSysTyVar tv_uniqs
tvtys = mkTyVarTys tvs
newrhss = map (flip mkApps (map Type tvtys)) rhss
insttys = snd3 . splitAlgTyConApp . head . fst . splitFunTys . coreExprType .
head
$ newrhss
(us1, us2) = splitUniqSupply supply
in
setUs us1 `thenUs_`
mapUs (mapUs (genConApp insttys)) dataconss `thenUs` \ lfuns ->
let
rexprs = cheapSimplify us2 emptyVarSet
. concat . map (\ (e, a) -> map (mkApps e . flip (:) [] . snd) a)
$ zip newrhss lfuns
in
trace (showSDoc (vcat [text "Attempted: " <> text (show (length tv_uniqs))
, ppr bdrs
, ppr (map coreExprType newrhss)
, ppr rexprs])) $
returnUs [Rec binds']
where
-- the original binds are used because that doesn't require them
-- to be sorted. The sort predicate assumes that the first
-- argument is a splitAlgTyConApp-able
-- DONT USE THESE names except for the guards: they are coming from the UNSORTED
bindings
(bdrs__, rhss__) = unzip binds__
(bdrss__, _) = unzip . map collectBinders $ rhss__
argss__ = map (fst . splitFunTys . snd . splitForAllTys . idType) bdrs__
-- END OF DONT USE
-- Don't split something which is marked unconditionally NOINLINE
never_inline fid = case getInlinePragma fid of
IMustNotBeINLINEd False Nothing -> True
other -> False
-- Re-sort the bindings to make sure that ordering matches that of in Derive
binds' = sortLt sortPredForBindings binds__
tc_group = map ( fst3 . splitAlgTyConApp . head . fst . splitFunTys
. snd . splitForAllTys . idType . fst)
$ binds'
-- all the data constructors in the RIGHT order (tycons are sorted)
dataconss = map tyConDataCons tc_group
(bdrs, rhss) = unzip binds'
(bdrss, _) = unzip . map collectBinders $ rhss
genConApp :: [Type] -> DataCon -> UniqSM ([Id], CoreExpr)
genConApp tys dcon
= getUniquesUs (length argtys) `thenUs` \ uniqs ->
let
arg_ids = map (\ (u, t, n) -> mkSysLocal (mkFastString (name ++ "_" ++ show
n)) u t)
$ zip3 uniqs argtys [1..]
in
returnUs (arg_ids, mkConApp dcon (map Type tys ++ map Var arg_ids))
where
argtys = dataConArgTys dcon tys
name = lowercase . getOccString . dataConName $ dcon
\end{code}
\begin{code}
cheapSimplify :: UniqSupply -> VarSet -> [CoreExpr] -> [CoreExpr]
cheapSimplify supply varset exprs
= case (initSmpl sw_chkr supply varset (\id -> True) (mapSmpl simplExpr exprs)) of
(exprs', _) -> exprs'
where
sw_chkr (MaxSimplifierIterations _) = SwInt 1
sw_chkr (SimplInlinePhase _) = SwInt 1
sw_chkr SimplLetToCase = SwBool False
sw_chkr DontApplyRules = SwBool False
\end{code}
\begin{code}
walkBind :: ([[TyCon]], [Id], [Id]) -> CoreBind -> UniqSM [CoreBind]
walkBind ids bind@(NonRec binder rhs)
= walkExpr ids rhs `thenUs` \ new_rhs ->
cataifySplit ids [ (binder, new_rhs) ]
walkBind ids (Rec pairs)
= mapUs (walkExpr ids) rhss `thenUs` \ new_rhss ->
cataifySplit ids (zip bdrs new_rhss)
where
(bdrs, rhss) = unzip pairs
walkExpr :: ([[TyCon]], [Id], [Id]) -> CoreExpr -> UniqSM CoreExpr
walkExpr ids e@(Type _) = returnUs e
walkExpr ids e@(Var _) = returnUs e
walkExpr ids (Con con args)
= mapUs (walkExpr ids) args `thenUs` \ args' ->
returnUs (Con con args')
walkExpr ids (Lam binder expr)
= walkExpr ids expr `thenUs` \ new_expr ->
returnUs (Lam binder new_expr)
walkExpr ids (App f a)
= walkExpr ids f `thenUs` \ new_f ->
walkExpr ids a `thenUs` \ new_a ->
returnUs (App new_f new_a)
walkExpr ids (Note note expr)
= walkExpr ids expr `thenUs` \ new_expr ->
returnUs (Note note new_expr)
walkExpr ids (Let bind expr)
= walkBind ids bind `thenUs` \ intermediate_bind ->
walkExpr ids expr `thenUs` \ new_expr ->
returnUs (mkLets intermediate_bind new_expr)
walkExpr ids (Case expr binder alts)
= walkExpr ids expr `thenUs` \ new_expr ->
mapUs walk_alt alts `thenUs` \ new_alts ->
returnUs (Case new_expr binder new_alts)
where
walk_alt (con, binders, rhs)
= walkExpr ids rhs `thenUs` \ new_rhs ->
returnUs (con, binders, new_rhs)
\end{code}
The rewrite engine
\begin{code}
type RewriteRule = (CoreExpr, CoreExpr)
type Trans a = a -> (a -> a) -> a -> a
rewrite :: Trans CoreExpr -> (CoreExpr -> CoreExpr)
rewrite sys term = rew term
where
rew = (\term -> sys term rew term) . distr rew
distr f expr
= case expr of
Var x -> Var x
Con con args -> Con con (map f args)
App e1 e2 -> App (f e1) (f e2)
Lam b e -> Lam b (f e)
Let bind e -> Let (appToBind bind) (f e)
Case e b alts -> Case (f e) b (map appToAlt alts)
Note note e -> Note note (f e)
Type t -> Type t
where
appToBind (NonRec b e) = NonRec b (f e)
appToBind (Rec pairs) = Rec [ (b, f e) | (b, e) <- pairs ]
appToAlt (con, bs, e) = (con, bs, f e)
\end{code}
