Commit a6b0ab26 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 1b3f2747 65e6470c
......@@ -66,6 +66,7 @@ module BasicTypes(
StrictnessMark(..), isMarkedStrict,
DefMethSpec(..),
SwapFlag(..), flipSwap, unSwap,
CompilerPhase(..), PhaseNum,
Activation(..), isActive, isActiveIn,
......@@ -123,6 +124,31 @@ type RepArity = Int
type Alignment = Int -- align to next N-byte boundary (N must be a power of 2).
\end{code}
%************************************************************************
%* *
Swap flag
%* *
%************************************************************************
\begin{code}
data SwapFlag
= NotSwapped -- Args are: actual, expected
| IsSwapped -- Args are: expected, actual
instance Outputable SwapFlag where
ppr IsSwapped = ptext (sLit "Is-swapped")
ppr NotSwapped = ptext (sLit "Not-swapped")
flipSwap :: SwapFlag -> SwapFlag
flipSwap IsSwapped = NotSwapped
flipSwap NotSwapped = IsSwapped
unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
unSwap NotSwapped f a b = f a b
unSwap IsSwapped f a b = f b a
\end{code}
%************************************************************************
%* *
\subsection[FunctionOrData]{FunctionOrData}
......
......@@ -37,7 +37,7 @@ module DataCon (
dataConRepStrictness,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
......@@ -838,8 +838,8 @@ dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++
\end{code}
\begin{code}
isTupleCon :: DataCon -> Bool
isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
isTupleDataCon :: DataCon -> Bool
isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
isUnboxedTupleCon :: DataCon -> Bool
isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
......
\begin{code}
module DataCon where
import Name( Name )
import {-# SOURCE #-} TyCon( TyCon )
data DataCon
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
instance Ord DataCon
......
......@@ -142,7 +142,7 @@ data IdDetails
-- instance C a => C [a]
-- has is_silent = 1, because the dfun
-- has type dfun :: (D a, C a) => C [a]
-- See the DFun Superclass Invariant in TcInstDcls
-- See Note [Silent superclass arguments] in TcInstDcls
--
-- Bool = True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
......
......@@ -751,9 +751,14 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
`setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` Just strict_sig
`setInlinePragInfo` neverInlinePragma
-- We give PrimOps a NOINLINE pragma so that we don't
-- get silly warnings from Desugar.dsRule (the inline_shadows_rule
-- test) about a RULE conflicting with a possible inlining
-- cf Trac #7287
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
......
......@@ -45,7 +45,7 @@ module Name (
-- ** Creating 'Name's
mkSystemName, mkSystemNameAt,
mkInternalName, mkDerivedInternalName,
mkInternalName, mkClonedInternalName, mkDerivedInternalName,
mkSystemVarName, mkSysTvName,
mkFCallName,
mkExternalName, mkWiredInName,
......@@ -266,6 +266,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq
-- * for interface files we tidyCore first, which makes
-- the OccNames distinct when they need to be
mkClonedInternalName :: Unique -> Name -> Name
mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
, n_occ = occ, n_loc = loc }
mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc })
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal
......
......@@ -27,7 +27,8 @@ module VarEnv (
modifyVarEnv, modifyVarEnv_Directly,
isEmptyVarEnv, foldVarEnv,
elemVarEnvByKey, lookupVarEnv_Directly,
filterVarEnv_Directly, restrictVarEnv,
filterVarEnv_Directly, restrictVarEnv,
partitionVarEnv,
-- * The InScopeSet type
InScopeSet,
......@@ -384,6 +385,7 @@ extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a
lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a
filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a
partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)
restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a
delVarEnvList :: VarEnv a -> [Var] -> VarEnv a
delVarEnv :: VarEnv a -> Var -> VarEnv a
......@@ -430,6 +432,7 @@ isEmptyVarEnv = isNullUFM
foldVarEnv = foldUFM
lookupVarEnv_Directly = lookupUFM_Directly
filterVarEnv_Directly = filterUFM_Directly
partitionVarEnv = partitionUFM
restrictVarEnv env vs = filterVarEnv_Directly keep env
where
......
......@@ -838,6 +838,19 @@ lintCoercion the_co@(NthCo n co)
_ -> failWithL (hang (ptext (sLit "Bad getNth:"))
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion the_co@(LRCo lr co)
= do { (_,s,t) <- lintCoercion co
; case (splitAppTy_maybe s, splitAppTy_maybe t) of
(Just s_pr, Just t_pr)
-> return (k, s_pick, t_pick)
where
s_pick = pickLR lr s_pr
t_pick = pickLR lr t_pr
k = typeKind s_pick
_ -> failWithL (hang (ptext (sLit "Bad LRCo:"))
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion (InstCo co arg_ty)
= do { (k,s,t) <- lintCoercion co
; arg_kind <- lintType arg_ty
......
......@@ -74,6 +74,9 @@ data Ty
| UnsafeCoercion Ty Ty
| InstCoercion Ty Ty
| NthCoercion Int Ty
| LRCoercion LeftOrRight Ty
data LeftOrRight = CLeft | CRight
data Kind
= Klifted
......
......@@ -326,8 +326,13 @@ make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (mak
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft = C.CLeft
make_lr CRight = C.CRight
-- Used for both tycon app coercions and axiom instantiations.
make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
make_conAppCo dflags con cos =
......
......@@ -114,6 +114,10 @@ pty (UnsafeCoercion t1 t2) =
sep [text "%unsafe", paty t1, paty t2]
pty (NthCoercion n t) =
sep [text "%nth", int n, paty t]
pty (LRCoercion CLeft t) =
sep [text "%left", paty t]
pty (LRCoercion CRight t) =
sep [text "%right", paty t]
pty (InstCoercion t1 t2) =
sep [text "%inst", paty t1, paty t2]
pty t = pbty t
......
......@@ -470,6 +470,8 @@ data CoercionMap a
, km_sym :: CoercionMap a
, km_trans :: CoercionMap (CoercionMap a)
, km_nth :: IntMap.IntMap (CoercionMap a)
, km_left :: CoercionMap a
, km_right :: CoercionMap a
, km_inst :: CoercionMap (TypeMap a) }
wrapEmptyKM :: CoercionMap a
......@@ -477,7 +479,8 @@ wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv
, km_app = emptyTM, km_forall = emptyTM
, km_var = emptyTM, km_axiom = emptyNameEnv
, km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM
, km_nth = emptyTM, km_inst = emptyTM }
, km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM
, km_inst = emptyTM }
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
......@@ -493,7 +496,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = kapp, km_forall = kforall
, km_var = kvar, km_axiom = kax
, km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans
, km_nth = knth, km_inst = kinst })
, km_nth = knth, km_left = kml, km_right = kmr
, km_inst = kinst })
= KM { km_refl = mapTM f krefl
, km_tc_app = mapNameEnv (mapTM f) ktc
, km_app = mapTM (mapTM f) kapp
......@@ -504,6 +508,8 @@ mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
, km_nth = IntMap.map (mapTM f) knth
, km_left = mapTM f kml
, km_right = mapTM f kmr
, km_inst = mapTM (mapTM f) kinst }
lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a
......@@ -522,6 +528,8 @@ lkC env co m
go (CoVarCo v) = km_var >.> lkVar env v
go (SymCo c) = km_sym >.> lkC env c
go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
go (LRCo CLeft c) = km_left >.> lkC env c
go (LRCo CRight c) = km_right >.> lkC env c
xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
xtC env co f EmptyKM = xtC env co f wrapEmptyKM
......@@ -534,9 +542,11 @@ xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>>
xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
|>> xtBndr env v f }
xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f }
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f }
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
fdC _ EmptyKM = \z -> z
......@@ -550,6 +560,8 @@ fdC k m = foldTM k (km_refl m)
. foldTM k (km_sym m)
. foldTM (foldTM k) (km_trans m)
. foldTM (foldTM k) (km_nth m)
. foldTM k (km_left m)
. foldTM k (km_right m)
. foldTM (foldTM k) (km_inst m)
\end{code}
......
......@@ -529,7 +529,7 @@ similar) at the same time that we create the constructors.
You can tell tuple constructors using
\begin{verbatim}
Id.isTupleCon
Id.isTupleDataCon
\end{verbatim}
You can see if one constructor is infix with this clearer code :-))))))))))
\begin{verbatim}
......
......@@ -576,6 +576,7 @@ addTickHsExpr (HsWrap w e) =
(addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr e@(HsType _) = return e
addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
-- Others dhould never happen in expression content.
addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)
......@@ -584,19 +585,19 @@ addTickTupArg :: HsTupArg Id -> TM (HsTupArg Id)
addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id -> TM (MatchGroup Id)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam (MatchGroup matches ty) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ MatchGroup matches' ty
addTickMatch :: Bool -> Bool -> Match Id -> TM (Match Id)
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ Match pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id -> TM (GRHSs Id)
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -605,7 +606,7 @@ addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
where
binders = collectLocalBinders local_binds
addTickGRHS :: Bool -> Bool -> GRHS Id -> TM (GRHS Id)
addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))
addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
......@@ -623,20 +624,20 @@ addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
_otherwise ->
addTickLHsExprRHS expr
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM [LStmt Id]
addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]
addTickLStmts isGuard stmts = do
(stmts, _) <- addTickLStmts' isGuard stmts (return ())
return stmts
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a
-> TM ([ExprLStmt Id], a)
addTickLStmts' isGuard lstmts res
= bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))
addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt
(addTickLHsExpr e)
......@@ -647,8 +648,8 @@ addTickStmt _isGuard (BindStmt pat e bind fail) = do
(addTickLHsExprRHS e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
liftM4 ExprStmt
addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
liftM4 BodyStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
......@@ -750,63 +751,65 @@ addTickLHsCmd (L pos c0) = do
return $ L pos c1
addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)
addTickHsCmd (HsLam matchgroup) =
liftM HsLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsApp c e) =
liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e)
addTickHsCmd (HsCmdLam matchgroup) =
liftM HsCmdLam (addTickCmdMatchGroup matchgroup)
addTickHsCmd (HsCmdApp c e) =
liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)
{-
addTickHsCmd (OpApp e1 c2 fix c3) =
liftM4 OpApp
(addTickLHsExpr e1)
(addTickLHsCmd c2)
(return fix)
(addTickLHsCmd c3)
addTickHsCmd (HsPar e) = liftM HsPar (addTickLHsCmd e)
addTickHsCmd (HsCase e mgs) =
liftM2 HsCase
-}
addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
addTickHsCmd (HsCmdCase e mgs) =
liftM2 HsCmdCase
(addTickLHsExpr e)
(addTickCmdMatchGroup mgs)
addTickHsCmd (HsIf cnd e1 c2 c3) =
liftM3 (HsIf cnd)
addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
liftM3 (HsCmdIf cnd)
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsLet binds c) =
addTickHsCmd (HsCmdLet binds c) =
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
liftM2 HsCmdLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts srcloc)
addTickHsCmd (HsCmdDo stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) }
; return (HsCmdDo stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsCmdArrApp
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
(return arr_ty)
(return lr)
addTickHsCmd (HsArrForm e fix cmdtop) =
liftM3 HsArrForm
addTickHsCmd (HsCmdArrForm e fix cmdtop) =
liftM3 HsCmdArrForm
(addTickLHsExpr e)
(return fix)
(mapM (liftL (addTickHsCmdTop)) cmdtop)
-- Others should never happen in a command context.
addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id -> TM (MatchGroup Id)
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup (MatchGroup matches ty) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ MatchGroup matches' ty
addTickCmdMatch :: Match Id -> TM (Match Id)
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match pats opSig gRHSs) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ Match pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id -> TM (GRHSs Id)
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs (GRHSs guarded local_binds) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
......@@ -815,7 +818,7 @@ addTickCmdGRHSs (GRHSs guarded local_binds) = do
where
binders = collectLocalBinders local_binds
addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))
-- The *guards* are *not* Cmds, although the body is
-- C.f. addTickGRHS for the BinBox stuff
addTickCmdGRHS (GRHS stmts cmd)
......@@ -823,12 +826,12 @@ addTickCmdGRHS (GRHS stmts cmd)
stmts (addTickLHsCmd cmd)
; return $ GRHS stmts' expr' }
addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]
addTickLCmdStmts stmts = do
(stmts, _) <- addTickLCmdStmts' stmts (return ())
return stmts
addTickLCmdStmts' :: [LStmt Id] -> TM a -> TM ([LStmt Id], a)
addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)
addTickLCmdStmts' lstmts res
= bindLocals binders $ do
lstmts' <- mapM (liftL addTickCmdStmt) lstmts
......@@ -837,7 +840,7 @@ addTickLCmdStmts' lstmts res
where
binders = collectLStmtsBinders lstmts
addTickCmdStmt :: Stmt Id -> TM (Stmt Id)
addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
addTickCmdStmt (BindStmt pat c bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
......@@ -848,8 +851,8 @@ addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
liftM4 ExprStmt
addTickCmdStmt (BodyStmt c bind' guard' ty) = do
liftM4 BodyStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
......@@ -1142,7 +1145,7 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
\begin{code}
matchesOneOfMany :: [LMatch Id] -> Bool
matchesOneOfMany :: [LMatch Id body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss
......
......@@ -50,31 +50,37 @@ import Outputable
import Bag
import VarSet
import SrcLoc
import ListSetOps( assocDefault )
import FastString
import Data.List
\end{code}
\begin{code}
data DsCmdEnv = DsCmdEnv {
meth_binds :: [CoreBind],
arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
}
mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
mkCmdEnv ids = do
(meth_binds, ds_meths) <- dsSyntaxTable ids
return $ DsCmdEnv {
meth_binds = meth_binds,
arr_id = Var (lookupEvidence ds_meths arrAName),
compose_id = Var (lookupEvidence ds_meths composeAName),
first_id = Var (lookupEvidence ds_meths firstAName),
app_id = Var (lookupEvidence ds_meths appAName),
choice_id = Var (lookupEvidence ds_meths choiceAName),
loop_id = Var (lookupEvidence ds_meths loopAName)
}
bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
bindCmdEnv ids body = foldr Let body (meth_binds ids)
mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)
-- See Note [CmdSyntaxTable] in HsExpr
mkCmdEnv tc_meths
= do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
; return (meth_binds, DsCmdEnv {
arr_id = Var (find_meth prs arrAName),
compose_id = Var (find_meth prs composeAName),
first_id = Var (find_meth prs firstAName),
app_id = Var (find_meth prs appAName),
choice_id = Var (find_meth prs choiceAName),
loop_id = Var (find_meth prs loopAName)
}) }
where
mk_bind (std_name, expr)
= do { rhs <- dsExpr expr
; id <- newSysLocalDs (exprType rhs)
; return (NonRec id rhs, (std_name, id)) }
find_meth prs std_name
= assocDefault (mk_panic std_name) prs std_name
mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)
-- arr :: forall b c. (b -> c) -> a b c
do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
......@@ -245,7 +251,7 @@ dsProcExpr
-> LHsCmdTop Id
-> DsM CoreExpr
dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
meth_ids <- mkCmdEnv ids
(meth_binds, meth_ids) <- mkCmdEnv ids
let locals = mkVarSet (collectPatBinders pat)
(core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
let env_ty = mkBigCoreVarTupTy env_ids
......@@ -256,7 +262,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
(Lam var match_code)
core_cmd
return (bindCmdEnv meth_ids proc_code)
return (mkLets meth_binds proc_code)
dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c)
\end{code}
......@@ -289,7 +295,7 @@ dsCmd :: DsCmdEnv -- arrow combinators
-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
(HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
......@@ -315,7 +321,7 @@ dsCmd ids local_vars stack res_ty
-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
dsCmd ids local_vars stack res_ty
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
(HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)
env_ids = do
let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
......@@ -344,7 +350,7 @@ dsCmd ids local_vars stack res_ty
--
-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
core_arg <- dsLExpr arg
let
arg_ty = exprType core_arg
......@@ -375,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars stack res_ty
(HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
(HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
env_ids = do
let
pat_vars = mkVarSet (collectPatsBinders pats)
......@@ -402,7 +408,7 @@ dsCmd ids local_vars stack res_ty
return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
free_vars `minusVarSet` pat_vars)
dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
dsCmd ids local_vars stack res_ty (HsCmdPar cmd) env_ids
= dsLCmd ids local_vars stack res_ty cmd env_ids
-- A, xs |- e :: Bool
......@@ -415,7 +421,7 @@ dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
-- c1 ||| c2
dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd)
dsCmd ids local_vars stack res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
env_ids = do
core_cond <- dsLExpr cond
(core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
......@@ -476,7 +482,7 @@ case bodies, containing the following fields:
bodies with |||.
\begin{code}
dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
env_ids = do
stack_ids <- mapM newSysLocalDs stack
......@@ -535,7 +541,7 @@ dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
--
-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
dsCmd ids local_vars stack res_ty (HsCmdLet binds body) env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars
......@@ -554,7 +560,7 @@ dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
core_body,
exprFreeIds core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
dsCmd ids local_vars [] res_ty (HsCmdDo stmts _) env_ids
= dsCmdDo ids local_vars res_ty stmts env_ids
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
......@@ -562,16 +568,16 @@ dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
-- -----------------------------------
-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do