import DsMonad
import DsGRHSs
import DsUtils
+import DsBreakpoint
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils
+import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
import OccurAnal
import CostCentre
import Module
import FastString
import Util ( mapSnd )
+import Name
+import OccName
+import Literal
+
import Control.Monad
import Data.List
\end{code}
\begin{code}
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do
+ mb_mod_name_ref <- getModNameRefDs
+ debugging <- breakpoints_enabled
+ case mb_mod_name_ref of
+ Nothing | debugging -> do -- Inject a CAF with the module name as literal
+ mod <- getModuleDs
+ mod_name_ref <- do
+ u <- newUnique
+ let n = mkSystemName u (mkVarOcc "_module")
+ return (mkLocalId n stringTy)
+ let mod_name = moduleNameFS$ moduleName mod
+ mod_lit <- dsExpr (HsLit (HsString mod_name))
+ withModNameRefDs mod_name_ref $ do
+ res <- ds_lhs_binds auto_scc binds
+ return$ (mod_name_ref, mod_lit) : res
+ _ -> ds_lhs_binds auto_scc binds
+
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = ds_lhs_binds NoSccs binds
addDictScc var core_expr `thenDs` \ core_expr' ->
returnDs ((var, core_expr') : rest)
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn })
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
= matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
- dsCoercion co_fn (return (mkLams args body)) `thenDs` \ rhs ->
+ mkOptTickBox tick body `thenDs` \ body' ->
+ dsCoercion co_fn (return (mkLams args body')) `thenDs` \ rhs ->
returnDs ((fun,rhs) : rest)
dsHsBind auto_scc rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
- -- some of the tyvars will be bound to voidTy
+ -- some of the tyvars will be bound to 'Any'
do { locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
; returnDs ((global', rhs) : spec_binds) }
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
- | otherwise = voidTy
+ | otherwise = mkArbitraryType all_tyvar
ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
(mkVarApps (Var spec_id) bndrs)
}
where
- -- Bind to voidTy any of all_ptvs that aren't
+ -- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
fix_up body | null void_tvs = body
| otherwise = mkTyApps (mkLams void_tvs body)
- (map (const voidTy) void_tvs)
+ (map mkArbitraryType void_tvs)
void_tvs = all_tvs \\ tvs
msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))