Commit faee23bb authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

vectorise: Put it out of its misery

Poor DPH and its vectoriser have long been languishing; sadly it seems there is
little chance that the effort will be rekindled. Every few years we discuss
what to do with this mass of code and at least once we have agreed that it
should be archived on a branch and removed from `master`. Here we do just that,
eliminating heaps of dead code in the process.

Here we drop the ParallelArrays extension, the vectoriser, and the `vector` and
`primitive` submodules.

Test Plan: Validate

Reviewers: simonpj, simonmar, hvr, goldfire, alanz

Reviewed By: simonmar

Subscribers: goldfire, rwbarton, thomie, mpickering, carter

Differential Revision: https://phabricator.haskell.org/D4761
parent 13a86606
...@@ -108,7 +108,6 @@ rnModIface hsc_env insts nsubst iface = do ...@@ -108,7 +108,6 @@ rnModIface hsc_env insts nsubst iface = do
deps <- rnDependencies (mi_deps iface) deps <- rnDependencies (mi_deps iface)
-- TODO: -- TODO:
-- mi_rules -- mi_rules
-- mi_vect_info (LOW PRIORITY)
return iface { mi_module = mod return iface { mi_module = mod
, mi_sig_of = sig_of , mi_sig_of = sig_of
, mi_insts = insts , mi_insts = insts
......
...@@ -20,9 +20,7 @@ module MkId ( ...@@ -20,9 +20,7 @@ module MkId (
mkPrimOpId, mkFCallId, mkPrimOpId, mkFCallId,
wrapNewTypeBody, unwrapNewTypeBody, wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody, unwrapFamInstScrut, wrapFamInstBody,
wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut,
DataConBoxer(..), mkDataConRep, mkDataConWorkId, DataConBoxer(..), mkDataConRep, mkDataConWorkId,
-- And some particular Ids; see below for why they are wired in -- And some particular Ids; see below for why they are wired in
...@@ -54,7 +52,6 @@ import CoreUtils ( exprType, mkCast ) ...@@ -54,7 +52,6 @@ import CoreUtils ( exprType, mkCast )
import CoreUnfold import CoreUnfold
import Literal import Literal
import TyCon import TyCon
import CoAxiom
import Class import Class
import NameSet import NameSet
import Name import Name
...@@ -1047,35 +1044,6 @@ wrapFamInstBody tycon args body ...@@ -1047,35 +1044,6 @@ wrapFamInstBody tycon args body
| otherwise | otherwise
= body = body
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> [Coercion]
-> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args cos body
= mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args cos))
wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> [Coercion]
-> CoreExpr -> CoreExpr
wrapTypeUnbranchedFamInstBody axiom
= wrapTypeFamInstBody axiom 0
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast scrut (mkUnbranchedAxInstCo Representational co_con args []) -- data instances only
| otherwise
= scrut
unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> [Coercion]
-> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom ind args cos scrut
= mkCast scrut (mkAxInstCo Representational axiom ind args cos)
unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> [Coercion]
-> CoreExpr -> CoreExpr
unwrapTypeUnbranchedFamInstScrut axiom
= unwrapTypeFamInstScrut axiom 0
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -78,8 +78,6 @@ module Module ...@@ -78,8 +78,6 @@ module Module
baseUnitId, baseUnitId,
rtsUnitId, rtsUnitId,
thUnitId, thUnitId,
dphSeqUnitId,
dphParUnitId,
mainUnitId, mainUnitId,
thisGhcUnitId, thisGhcUnitId,
isHoleModule, isHoleModule,
...@@ -1067,8 +1065,7 @@ parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') ...@@ -1067,8 +1065,7 @@ parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')
integerUnitId, primUnitId, integerUnitId, primUnitId,
baseUnitId, rtsUnitId, baseUnitId, rtsUnitId,
thUnitId, dphSeqUnitId, dphParUnitId, thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
primUnitId = fsToUnitId (fsLit "ghc-prim") primUnitId = fsToUnitId (fsLit "ghc-prim")
integerUnitId = fsToUnitId (fsLit n) integerUnitId = fsToUnitId (fsLit n)
where where
...@@ -1078,8 +1075,6 @@ integerUnitId = fsToUnitId (fsLit n) ...@@ -1078,8 +1075,6 @@ integerUnitId = fsToUnitId (fsLit n)
baseUnitId = fsToUnitId (fsLit "base") baseUnitId = fsToUnitId (fsLit "base")
rtsUnitId = fsToUnitId (fsLit "rts") rtsUnitId = fsToUnitId (fsLit "rts")
thUnitId = fsToUnitId (fsLit "template-haskell") thUnitId = fsToUnitId (fsLit "template-haskell")
dphSeqUnitId = fsToUnitId (fsLit "dph-seq")
dphParUnitId = fsToUnitId (fsLit "dph-par")
thisGhcUnitId = fsToUnitId (fsLit "ghc") thisGhcUnitId = fsToUnitId (fsLit "ghc")
interactiveUnitId = fsToUnitId (fsLit "interactive") interactiveUnitId = fsToUnitId (fsLit "interactive")
...@@ -1127,9 +1122,7 @@ wiredInUnitIds = [ primUnitId, ...@@ -1127,9 +1122,7 @@ wiredInUnitIds = [ primUnitId,
baseUnitId, baseUnitId,
rtsUnitId, rtsUnitId,
thUnitId, thUnitId,
thisGhcUnitId, thisGhcUnitId ]
dphSeqUnitId,
dphParUnitId ]
{- {-
************************************************************************ ************************************************************************
......
...@@ -51,7 +51,6 @@ module Name ( ...@@ -51,7 +51,6 @@ module Name (
setNameLoc, setNameLoc,
tidyNameOcc, tidyNameOcc,
localiseName, localiseName,
mkLocalisedOccName,
nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
...@@ -414,18 +413,6 @@ tidyNameOcc name occ = name { n_occ = occ } ...@@ -414,18 +413,6 @@ tidyNameOcc name occ = name { n_occ = occ }
localiseName :: Name -> Name localiseName :: Name -> Name
localiseName n = n { n_sort = Internal } localiseName n = n { n_sort = Internal }
-- |Create a localised variant of a name.
--
-- If the name is external, encode the original's module name to disambiguate.
-- SPJ says: this looks like a rather odd-looking function; but it seems to
-- be used only during vectorisation, so I'm not going to worry
mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName
mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
where
origin
| nameIsLocalOrFrom this_mod name = Nothing
| otherwise = Just (moduleNameColons . moduleName . nameModule $ name)
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -67,11 +67,6 @@ module OccName ( ...@@ -67,11 +67,6 @@ module OccName (
mkSuperDictSelOcc, mkSuperDictAuxOcc, mkSuperDictSelOcc, mkSuperDictAuxOcc,
mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkInstTyCoOcc, mkEqPredCoOcc,
mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
mkPDataTyConOcc, mkPDataDataConOcc,
mkPDatasTyConOcc, mkPDatasDataConOcc,
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc, mkRecFldSelOcc,
mkTyConRepOcc, mkTyConRepOcc,
...@@ -655,23 +650,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ ...@@ -655,23 +650,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ
mkGenR = mk_simple_deriv tcName "Rep_" mkGenR = mk_simple_deriv tcName "Rep_"
mkGen1R = mk_simple_deriv tcName "Rep1_" mkGen1R = mk_simple_deriv tcName "Rep1_"
-- Vectorisation
mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
mkPADFunOcc, mkPReprTyConOcc,
mkPDataTyConOcc, mkPDataDataConOcc,
mkPDatasTyConOcc, mkPDatasDataConOcc
:: Maybe String -> OccName -> OccName
mkVectOcc = mk_simple_deriv_with varName "$v"
mkVectTyConOcc = mk_simple_deriv_with tcName "V:"
mkVectDataConOcc = mk_simple_deriv_with dataName "VD:"
mkVectIsoOcc = mk_simple_deriv_with varName "$vi"
mkPADFunOcc = mk_simple_deriv_with varName "$pa"
mkPReprTyConOcc = mk_simple_deriv_with tcName "VR:"
mkPDataTyConOcc = mk_simple_deriv_with tcName "VP:"
mkPDatasTyConOcc = mk_simple_deriv_with tcName "VPs:"
mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:"
mkPDatasDataConOcc = mk_simple_deriv_with dataName "VPDs:"
-- Overloaded record field selectors -- Overloaded record field selectors
mkRecFldSelOcc :: String -> OccName mkRecFldSelOcc :: String -> OccName
mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]
...@@ -679,15 +657,6 @@ mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] ...@@ -679,15 +657,6 @@ mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s]
mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName
mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ]
mk_simple_deriv_with :: NameSpace -- ^ the namespace
-> FastString -- ^ an identifying prefix
-> Maybe String -- ^ another optional prefix
-> OccName -- ^ the 'OccName' to derive from
-> OccName
mk_simple_deriv_with sp px Nothing occ = mk_deriv sp px [occNameFS occ]
mk_simple_deriv_with sp px (Just with) occ =
mk_deriv sp px [fsLit with, fsLit "_", occNameFS occ]
-- Data constructor workers are made by setting the name space -- Data constructor workers are made by setting the name space
-- of the data constructor OccName (which should be a DataName) -- of the data constructor OccName (which should be a DataName)
-- to VarName -- to VarName
......
...@@ -49,7 +49,7 @@ module Unique ( ...@@ -49,7 +49,7 @@ module Unique (
mkPrimOpIdUnique, mkPrimOpIdUnique,
mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique, mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique, mkCoVarUnique, mkCoVarUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
...@@ -369,7 +369,6 @@ mkPreludeTyConUnique :: Int -> Unique ...@@ -369,7 +369,6 @@ mkPreludeTyConUnique :: Int -> Unique
mkPreludeDataConUnique :: Arity -> Unique mkPreludeDataConUnique :: Arity -> Unique
mkPrimOpIdUnique :: Int -> Unique mkPrimOpIdUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique
mkPArrDataConUnique :: Int -> Unique
mkCoVarUnique :: Int -> Unique mkCoVarUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i mkAlphaTyVarUnique i = mkUnique '1' i
...@@ -409,9 +408,6 @@ dataConRepNameUnique u = stepUnique u 2 ...@@ -409,9 +408,6 @@ dataConRepNameUnique u = stepUnique u 2
mkPrimOpIdUnique op = mkUnique '9' op mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i mkPreludeMiscIdUnique i = mkUnique '0' i
-- No numbers left anymore, so I pick something different for the character tag
mkPArrDataConUnique a = mkUnique ':' (2*a)
-- The "tyvar uniques" print specially nicely: a, b, c, etc. -- The "tyvar uniques" print specially nicely: a, b, c, etc.
-- See pprUnique for details -- See pprUnique for details
......
...@@ -37,7 +37,6 @@ module CoreFVs ( ...@@ -37,7 +37,6 @@ module CoreFVs (
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet, rulesFreeVarsDSet,
ruleLhsFreeIds, ruleLhsFreeIdsList, ruleLhsFreeIds, ruleLhsFreeIdsList,
vectsFreeVars,
expr_fvs, expr_fvs,
...@@ -515,17 +514,6 @@ put this 'f' in a Rec block, but will mark the binding as a non-rule loop ...@@ -515,17 +514,6 @@ put this 'f' in a Rec block, but will mark the binding as a non-rule loop
breaker, which is perfectly inlinable. breaker, which is perfectly inlinable.
-} -}
-- |Free variables of a vectorisation declaration
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = mapUnionVarSet vectFreeVars
where
vectFreeVars (Vect _ rhs) = fvVarSet $ filterFV isLocalId $ expr_fvs rhs
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _) = noFVs
-- this function is only concerned with values, not types
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -274,7 +274,6 @@ coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper ...@@ -274,7 +274,6 @@ coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse coreDumpFlag CoreCSE = Just Opt_D_dump_cse
coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt
coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
coreDumpFlag CoreTidy = Just Opt_D_dump_simpl coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
......
...@@ -127,25 +127,24 @@ simpleOptExprWith subst expr ...@@ -127,25 +127,24 @@ simpleOptExprWith subst expr
---------------------- ----------------------
simpleOptPgm :: DynFlags -> Module simpleOptPgm :: DynFlags -> Module
-> CoreProgram -> [CoreRule] -> [CoreVect] -> CoreProgram -> [CoreRule]
-> IO (CoreProgram, [CoreRule], [CoreVect]) -> IO (CoreProgram, [CoreRule])
-- See Note [The simple optimiser] -- See Note [The simple optimiser]
simpleOptPgm dflags this_mod binds rules vects simpleOptPgm dflags this_mod binds rules
= do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings occ_anald_binds $$ pprRules rules ); (pprCoreBindings occ_anald_binds $$ pprRules rules );
; return (reverse binds', rules', vects') } ; return (reverse binds', rules') }
where where
occ_anald_binds = occurAnalysePgm this_mod occ_anald_binds = occurAnalysePgm this_mod
(\_ -> True) {- All unfoldings active -} (\_ -> True) {- All unfoldings active -}
(\_ -> False) {- No rules active -} (\_ -> False) {- No rules active -}
rules vects emptyVarSet binds rules binds
(final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds (final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
final_subst = soe_subst final_env final_subst = soe_subst final_env
rules' = substRulesForImportedIds final_subst rules rules' = substRulesForImportedIds final_subst rules
vects' = substVects final_subst vects
-- We never unconditionally inline into rules, -- We never unconditionally inline into rules,
-- hence paying just a substitution -- hence paying just a substitution
...@@ -536,18 +535,6 @@ wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr ...@@ -536,18 +535,6 @@ wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body wrapLet Nothing body = body
wrapLet (Just (b,r)) body = Let (NonRec b r) body wrapLet (Just (b,r)) body = Let (NonRec b r) body
------------------
substVects :: Subst -> [CoreVect] -> [CoreVect]
substVects subst = map (substVect subst)
------------------
substVect :: Subst -> CoreVect -> CoreVect
substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs)
substVect _subst vd@(NoVect _) = vd
substVect _subst vd@(VectType _ _ _) = vd
substVect _subst vd@(VectClass _) = vd
substVect _subst vd@(VectInst _) = vd
{- {-
Note [Inline prag in simplOpt] Note [Inline prag in simplOpt]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -92,9 +92,6 @@ module CoreSyn ( ...@@ -92,9 +92,6 @@ module CoreSyn (
ruleArity, ruleName, ruleIdName, ruleActivation, ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName, ruleModule, setRuleIdName, ruleModule,
isBuiltinRule, isLocalRule, isAutoRule, isBuiltinRule, isLocalRule, isAutoRule,
-- * Core vectorisation declarations data type
CoreVect(..)
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -112,7 +109,6 @@ import NameEnv( NameEnv, emptyNameEnv ) ...@@ -112,7 +109,6 @@ import NameEnv( NameEnv, emptyNameEnv )
import Literal import Literal
import DataCon import DataCon
import Module import Module
import TyCon
import BasicTypes import BasicTypes
import DynFlags import DynFlags
import Outputable import Outputable
...@@ -1302,23 +1298,6 @@ isLocalRule = ru_local ...@@ -1302,23 +1298,6 @@ isLocalRule = ru_local
setRuleIdName :: Name -> CoreRule -> CoreRule setRuleIdName :: Name -> CoreRule -> CoreRule
setRuleIdName nm ru = ru { ru_fn = nm } setRuleIdName nm ru = ru { ru_fn = nm }
{-
************************************************************************
* *
\subsection{Vectorisation declarations}
* *
************************************************************************
Representation of desugared vectorisation declarations that are fed to the vectoriser (via
'ModGuts').
-}
data CoreVect = Vect Id CoreExpr
| NoVect Id
| VectType Bool TyCon (Maybe TyCon)
| VectClass TyCon -- class tycon
| VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -612,21 +612,3 @@ instance Outputable id => Outputable (Tickish id) where ...@@ -612,21 +612,3 @@ instance Outputable id => Outputable (Tickish id) where
ppr (SourceNote span _) = ppr (SourceNote span _) =
hcat [ text "src<", pprUserRealSpan True span, char '>'] hcat [ text "src<", pprUserRealSpan True span, char '>']
{-
-----------------------------------------------------
-- Vectorisation declarations
-----------------------------------------------------
-}
instance Outputable CoreVect where
ppr (Vect var e) = hang (text "VECTORISE" <+> ppr var <+> char '=')
4 (pprCoreExpr e)
ppr (NoVect var) = text "NOVECTORISE" <+> ppr var
ppr (VectType False var Nothing) = text "VECTORISE type" <+> ppr var
ppr (VectType True var Nothing) = text "VECTORISE SCALAR type" <+> ppr var
ppr (VectType False var (Just tc)) = text "VECTORISE type" <+> ppr var <+> char '=' <+>
ppr tc
ppr (VectType True var (Just tc)) = text "VECTORISE SCALAR type" <+> ppr var <+>
char '=' <+> ppr tc
ppr (VectClass tc) = text "VECTORISE class" <+> ppr tc
ppr (VectInst var) = text "VECTORISE SCALAR instance" <+> ppr var
...@@ -841,11 +841,6 @@ translatePat fam_insts pat = case pat of ...@@ -841,11 +841,6 @@ translatePat fam_insts pat = case pat of
(map (LitPat noExt . HsChar src) (unpackFS s)) (map (LitPat noExt . HsChar src) (unpackFS s))
| otherwise -> return [mkLitPattern lit] | otherwise -> return [mkLitPattern lit]
PArrPat ty ps -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let fake_con = RealDataCon (parrFakeCon (length ps))
return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
TuplePat tys ps boxity -> do TuplePat tys ps boxity -> do
tidy_ps <- translatePatVec fam_insts (map unLoc ps) tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let tuple_con = RealDataCon (tupleDataCon boxity (length ps)) let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
......
...@@ -562,10 +562,6 @@ addTickHsExpr (ExplicitList ty wit es) = ...@@ -562,10 +562,6 @@ addTickHsExpr (ExplicitList ty wit es) =
addTickWit (Just fln) addTickWit (Just fln)
= do fln' <- addTickSyntaxExpr hpcSrcSpan fln = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
return (Just fln') return (Just fln')
addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr
(return ty)
(mapM (addTickLHsExpr) es)
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
...@@ -602,10 +598,6 @@ addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do ...@@ -602,10 +598,6 @@ addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $ e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0 addTickHsExpr e0
return $ unLoc e2 return $ unLoc e2
addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq
(return ty)
(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC x src nm e) = addTickHsExpr (HsSCC x src nm e) =
liftM3 (HsSCC x) liftM3 (HsSCC x)
(return src) (return src)
......
...@@ -28,8 +28,6 @@ import TcRnDriver ( runTcInteractive ) ...@@ -28,8 +28,6 @@ import TcRnDriver ( runTcInteractive )
import Id import Id
import Name import Name
import Type import Type
import InstEnv
import Class
import Avail import Avail
import CoreSyn import CoreSyn
import CoreFVs ( exprsSomeFreeVarsList ) import CoreFVs ( exprsSomeFreeVarsList )
...@@ -104,7 +102,6 @@ deSugar hsc_env ...@@ -104,7 +102,6 @@ deSugar hsc_env
tcg_th_foreign_files = th_foreign_files_var, tcg_th_foreign_files = th_foreign_files_var,
tcg_fords = fords, tcg_fords = fords,
tcg_rules = rules, tcg_rules = rules,
tcg_vects = vects,
tcg_patsyns = patsyns, tcg_patsyns = patsyns,
tcg_tcs = tcs, tcg_tcs = tcs,
tcg_insts = insts, tcg_insts = insts,
...@@ -134,18 +131,17 @@ deSugar hsc_env ...@@ -134,18 +131,17 @@ deSugar hsc_env
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords ; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules ; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects
; let hpc_init ; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty | otherwise = empty
; return ( ds_ev_binds ; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs , foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects , spec_rules ++ ds_rules
, ds_fords `appendStubC` hpc_init) } , ds_fords `appendStubC` hpc_init) }
; case mb_res of { ; case mb_res of {
Nothing -> return (msgs, Nothing) ; Nothing -> return (msgs, Nothing) ;
Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
do { -- Add export flags to bindings do { -- Add export flags to bindings
keep_alive <- readIORef keep_var keep_alive <- readIORef keep_var
...@@ -162,8 +158,8 @@ deSugar hsc_env ...@@ -162,8 +158,8 @@ deSugar hsc_env
-- things into the in-scope set before simplifying; so we get no unfolding for F#! -- things into the in-scope set before simplifying; so we get no unfolding for F#!
; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
; (ds_binds, ds_rules_for_imps, ds_vects) ; (ds_binds, ds_rules_for_imps)
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 <- simpleOptPgm dflags mod final_pgm rules_for_imps
-- The simpleOptPgm gets rid of type -- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code -- bindings plus any stupid dead code
...@@ -211,8 +207,6 @@ deSugar hsc_env ...@@ -211,8 +207,6 @@ deSugar hsc_env
mg_foreign_files = foreign_files, mg_foreign_files = foreign_files,
mg_hpc_info = ds_hpc_info, mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks, mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode, mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports, mg_trust_pkg = imp_trust_own_pkg imports,