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
deps <- rnDependencies (mi_deps iface)
-- TODO:
-- mi_rules
-- mi_vect_info (LOW PRIORITY)
return iface { mi_module = mod
, mi_sig_of = sig_of
, mi_insts = insts
......
......@@ -20,9 +20,7 @@ module MkId (
mkPrimOpId, mkFCallId,
wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody, unwrapFamInstScrut,
wrapTypeUnbranchedFamInstBody, unwrapTypeUnbranchedFamInstScrut,
wrapFamInstBody,
DataConBoxer(..), mkDataConRep, mkDataConWorkId,
-- And some particular Ids; see below for why they are wired in
......@@ -54,7 +52,6 @@ import CoreUtils ( exprType, mkCast )
import CoreUnfold
import Literal
import TyCon
import CoAxiom
import Class
import NameSet
import Name
......@@ -1047,35 +1044,6 @@ wrapFamInstBody tycon args body
| otherwise
= 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
baseUnitId,
rtsUnitId,
thUnitId,
dphSeqUnitId,
dphParUnitId,
mainUnitId,
thisGhcUnitId,
isHoleModule,
......@@ -1067,8 +1065,7 @@ parseModSubst = Parse.between (Parse.char '[') (Parse.char ']')
integerUnitId, primUnitId,
baseUnitId, rtsUnitId,
thUnitId, dphSeqUnitId, dphParUnitId,
mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
primUnitId = fsToUnitId (fsLit "ghc-prim")
integerUnitId = fsToUnitId (fsLit n)
where
......@@ -1078,8 +1075,6 @@ integerUnitId = fsToUnitId (fsLit n)
baseUnitId = fsToUnitId (fsLit "base")
rtsUnitId = fsToUnitId (fsLit "rts")
thUnitId = fsToUnitId (fsLit "template-haskell")
dphSeqUnitId = fsToUnitId (fsLit "dph-seq")
dphParUnitId = fsToUnitId (fsLit "dph-par")
thisGhcUnitId = fsToUnitId (fsLit "ghc")
interactiveUnitId = fsToUnitId (fsLit "interactive")
......@@ -1127,9 +1122,7 @@ wiredInUnitIds = [ primUnitId,
baseUnitId,
rtsUnitId,
thUnitId,
thisGhcUnitId,
dphSeqUnitId,
dphParUnitId ]
thisGhcUnitId ]
{-
************************************************************************
......
......@@ -51,7 +51,6 @@ module Name (
setNameLoc,
tidyNameOcc,
localiseName,
mkLocalisedOccName,
nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
......@@ -414,18 +413,6 @@ tidyNameOcc name occ = name { n_occ = occ }
localiseName :: Name -> Name
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 (
mkSuperDictSelOcc, mkSuperDictAuxOcc,
mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
mkPDataTyConOcc, mkPDataDataConOcc,
mkPDatasTyConOcc, mkPDatasDataConOcc,
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
mkTyConRepOcc,
......@@ -655,23 +650,6 @@ mkTyConRepOcc occ = mk_simple_deriv varName prefix occ
mkGenR = mk_simple_deriv tcName "Rep_"
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
mkRecFldSelOcc :: String -> OccName
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 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
-- of the data constructor OccName (which should be a DataName)
-- to VarName
......
......@@ -49,7 +49,7 @@ module Unique (
mkPrimOpIdUnique,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique, mkCoVarUnique,
mkCoVarUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
......@@ -369,7 +369,6 @@ mkPreludeTyConUnique :: Int -> Unique
mkPreludeDataConUnique :: Arity -> Unique
mkPrimOpIdUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique
mkPArrDataConUnique :: Int -> Unique
mkCoVarUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
......@@ -409,9 +408,6 @@ dataConRepNameUnique u = stepUnique u 2
mkPrimOpIdUnique op = mkUnique '9' op
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.
-- See pprUnique for details
......
......@@ -37,7 +37,6 @@ module CoreFVs (
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
rulesFreeVarsDSet,
ruleLhsFreeIds, ruleLhsFreeIdsList,
vectsFreeVars,
expr_fvs,
......@@ -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.
-}
-- |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
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse
coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt
coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds
coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
......
......@@ -127,25 +127,24 @@ simpleOptExprWith subst expr
----------------------
simpleOptPgm :: DynFlags -> Module
-> CoreProgram -> [CoreRule] -> [CoreVect]
-> IO (CoreProgram, [CoreRule], [CoreVect])
-> CoreProgram -> [CoreRule]
-> IO (CoreProgram, [CoreRule])
-- 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"
(pprCoreBindings occ_anald_binds $$ pprRules rules );
; return (reverse binds', rules', vects') }
; return (reverse binds', rules') }
where
occ_anald_binds = occurAnalysePgm this_mod
(\_ -> True) {- All unfoldings active -}
(\_ -> False) {- No rules active -}
rules vects emptyVarSet binds
rules binds
(final_env, binds') = foldl do_one (emptyEnv, []) occ_anald_binds
final_subst = soe_subst final_env
rules' = substRulesForImportedIds final_subst rules
vects' = substVects final_subst vects
-- We never unconditionally inline into rules,
-- hence paying just a substitution
......@@ -536,18 +535,6 @@ wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -92,9 +92,6 @@ module CoreSyn (
ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName, ruleModule,
isBuiltinRule, isLocalRule, isAutoRule,
-- * Core vectorisation declarations data type
CoreVect(..)
) where
#include "HsVersions.h"
......@@ -112,7 +109,6 @@ import NameEnv( NameEnv, emptyNameEnv )
import Literal
import DataCon
import Module
import TyCon
import BasicTypes
import DynFlags
import Outputable
......@@ -1302,23 +1298,6 @@ isLocalRule = ru_local
setRuleIdName :: Name -> CoreRule -> CoreRule
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
ppr (SourceNote span _) =
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
(map (LitPat noExt . HsChar src) (unpackFS s))
| 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
tidy_ps <- translatePatVec fam_insts (map unLoc ps)
let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
......
......@@ -562,10 +562,6 @@ addTickHsExpr (ExplicitList ty wit es) =
addTickWit (Just fln)
= do fln' <- addTickSyntaxExpr hpcSrcSpan fln
return (Just fln')
addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr
(return ty)
(mapM (addTickLHsExpr) es)
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
......@@ -602,10 +598,6 @@ addTickHsExpr (HsTickPragma _ _ _ _ (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0
return $ unLoc e2
addTickHsExpr (PArrSeq ty arith_seq) =
liftM2 PArrSeq
(return ty)
(addTickArithSeqInfo arith_seq)
addTickHsExpr (HsSCC x src nm e) =
liftM3 (HsSCC x)
(return src)
......
......@@ -28,8 +28,6 @@ import TcRnDriver ( runTcInteractive )
import Id
import Name
import Type
import InstEnv
import Class
import Avail
import CoreSyn
import CoreFVs ( exprsSomeFreeVarsList )
......@@ -104,7 +102,6 @@ deSugar hsc_env
tcg_th_foreign_files = th_foreign_files_var,
tcg_fords = fords,
tcg_rules = rules,
tcg_vects = vects,
tcg_patsyns = patsyns,
tcg_tcs = tcs,
tcg_insts = insts,
......@@ -134,18 +131,17 @@ deSugar hsc_env
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
, spec_rules ++ ds_rules, ds_vects
, spec_rules ++ ds_rules
, ds_fords `appendStubC` hpc_init) }
; case mb_res of {
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
keep_alive <- readIORef keep_var
......@@ -162,8 +158,8 @@ deSugar hsc_env
-- 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
; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
; (ds_binds, ds_rules_for_imps)
<- simpleOptPgm dflags mod final_pgm rules_for_imps
-- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code
......@@ -211,8 +207,6 @@ deSugar hsc_env
mg_foreign_files = foreign_files,
mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports,
mg_complete_sigs = complete_matches
......@@ -548,32 +542,4 @@ and similar, which will elicit exactly these warnings, and risk never
firing. But it's not clear what to do instead. We could make the
class method rules inactive in phase 2, but that would delay when
subsequent transformations could fire.
************************************************************************
* *
* Desugaring vectorisation declarations
* *
************************************************************************
-}
dsVect :: LVectDecl GhcTc -> DsM CoreVect
dsVect (L loc (HsVect _ _ (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- dsLExpr rhs
; return $ Vect v rhs'
}
dsVect (L _loc (HsNoVect _ _ (L _ v)))
= return $ NoVect v
dsVect (L _loc (HsVectType (VectTypeTc tycon rhs_tycon) isScalar))
= return $ VectType isScalar tycon' rhs_tycon
where
tycon' | Just ty <- coreView $ mkTyConTy tycon
, (tycon', []) <- splitTyConApp ty = tycon'
| otherwise = tycon
dsVect (L _loc (HsVectClass cls))
= return $ VectClass (classTyCon cls)
dsVect (L _loc (HsVectInst inst))
= return $ VectInst (instanceDFunId inst)
dsVect vd@(L _ (XVectDecl {}))
= pprPanic "Desugar.dsVect: unexpected 'XVectDecl'" (ppr vd)
......@@ -1213,7 +1213,6 @@ collectl (L _ pat) bndrs
go (ParPat _ pat) = collectl pat bndrs
go (ListPat _ pats) = foldr collectl bndrs pats
go (PArrPat _ pats) = foldr collectl bndrs pats
go (TuplePat _ pats _) = foldr collectl bndrs pats
go (SumPat _ pat _ _) = collectl pat bndrs
......
......@@ -423,7 +423,6 @@ ds_expr _ (HsLet _ binds body) = do
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
ds_expr _ (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
ds_expr _ (HsDo _ PArrComp (L _ stmts)) = dsPArrComp (map unLoc stmts)
ds_expr _ (HsDo _ DoExpr (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ GhciStmtCtxt (L _ stmts)) = dsDo stmts
ds_expr _ (HsDo _ MDoExpr (L _ stmts)) = dsDo stmts
......@@ -460,38 +459,12 @@ ds_expr _ (HsMultiIf res_ty alts)
ds_expr _ (ExplicitList elt_ty wit xs)
= dsExplicitList elt_ty wit xs
-- We desugar [:x1, ..., xn:] as
-- singletonP x1 +:+ ... +:+ singletonP xn
--
ds_expr _ (ExplicitPArr ty []) = do
emptyP <- dsDPHBuiltin emptyPVar
return (Var emptyP `App` Type ty)
ds_expr _ (ExplicitPArr ty xs) = do
singletonP <- dsDPHBuiltin singletonPVar
appP <- dsDPHBuiltin appPVar
xs' <- mapM dsLExprNoLP xs
let unary fn x = mkApps (Var fn) [Type ty, x]
binary fn x y = mkApps (Var fn) [Type ty, x, y]
return . foldr1 (binary appP) $ map (unary singletonP) xs'
ds_expr _ (ArithSeq expr witness seq)
= case witness of
Nothing -> dsArithSeq expr seq
Just fl -> do { newArithSeq <- dsArithSeq expr seq
; dsSyntaxExpr fl [newArithSeq] }
ds_expr _ (PArrSeq expr (FromTo from to))
= mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to]
ds_expr _ (PArrSeq expr (FromThenTo from thn to))
= mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to]
ds_expr _ (PArrSeq _ _)
= panic "DsExpr.dsExpr: Infinite parallel array!"
-- the parser shouldn't have generated it and the renamer and typechecker
-- shouldn't have let it through
{-
Static Pointers
~~~~~~~~~~~~~~~
......
......@@ -9,7 +9,7 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions
{-# LANGUAGE CPP, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
module DsListComp ( dsListComp, dsMonadComp ) where
#include "HsVersions.h"
......@@ -476,214 +476,6 @@ mkUnzipBind _ elt_tys
mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
{-
************************************************************************
* *
\subsection[DsPArrComp]{Desugaring of array comprehensions}
* *
************************************************************************
-}
-- entry point for desugaring a parallel array comprehension
--
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [ExprStmt GhcTc]
-> DsM CoreExpr
-- Special case for parallel comprehension
dsPArrComp (ParStmt _ qss _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
-- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e
--
-- if matching again p cannot fail, or else
--
-- <<[:e' | p <- e, qs:]>> =
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
dsPArrComp (BindStmt _ p e _ _ : qs) = do
filterP <- dsDPHBuiltin filterPVar
ce <- dsLExprNoLP e
let ety'ce = parrElemType ce
false = Var falseDataConId
true = Var trueDataConId
v <- newSysLocalDs ety'ce
pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
let gen | isIrrefutableHsPat p = ce
| otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
dePArrComp qs p gen
dsPArrComp qs = do -- no ParStmt in `qs'
sglP <- dsDPHBuiltin singletonPVar
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
dePArrComp qs (noLoc $ WildPat unitTy) unitArray
-- the work horse
--
dePArrComp :: [ExprStmt GhcTc]
-> LPat GhcTc -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
dePArrComp [] _ _ = panic "dePArrComp"
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
dePArrComp (LastStmt _ e' _ _ : quals) pa cea
= ASSERT( null quals )
do { mapP <- dsDPHBuiltin mapPVar
; let ty = parrElemType cea
; (clam, ty'e') <- deLambda ty pa e'
; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
dePArrComp (BodyStmt _ b _ _ : qs) pa cea = do
filterP <- dsDPHBuiltin filterPVar
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
--
-- <<[:e' | p <- e, qs:]>> pa ea =
-- let ef = \pa -> e
-- in
-- <<[:e' | qs:]>> (pa, p) (crossMap ea ef)
--
-- if matching again p cannot fail, or else
--
-- <<[:e' | p <- e, qs:]>> pa ea =
-- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e
-- in