summaryrefslogtreecommitdiff
path: root/compiler/deSugar
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/deSugar')
-rw-r--r--compiler/deSugar/Desugar.lhs58
-rw-r--r--compiler/deSugar/DsExpr.lhs6
-rw-r--r--compiler/deSugar/DsListComp.lhs16
-rw-r--r--compiler/deSugar/DsMonad.lhs35
-rw-r--r--compiler/deSugar/DsUtils.lhs4
5 files changed, 81 insertions, 38 deletions
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 60dec3047a..142f695cb5 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -69,12 +69,13 @@ deSugar hsc_env
tcg_anns = anns,
tcg_binds = binds,
tcg_imp_specs = imp_specs,
- tcg_ev_binds = ev_binds,
- tcg_fords = fords,
- tcg_rules = rules,
- tcg_insts = insts,
- tcg_fam_insts = fam_insts,
- tcg_hpc = other_hpc_info })
+ tcg_ev_binds = ev_binds,
+ tcg_fords = fords,
+ tcg_rules = rules,
+ tcg_vects = vects,
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts,
+ tcg_hpc = other_hpc_info })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Desugar"
@@ -88,7 +89,7 @@ deSugar hsc_env
<- case target of
HscNothing ->
return (emptyMessages,
- Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks))
+ Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do
(binds_cvr,ds_hpc_info, modBreaks)
<- if (opt_Hpc
@@ -98,19 +99,20 @@ deSugar hsc_env
(typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
- do { ds_ev_binds <- dsEvBinds ev_binds
- ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
+ do { ds_ev_binds <- dsEvBinds ev_binds
+ ; core_prs <- dsTopLHsBinds auto_scc binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
- ; (ds_fords, foreign_prs) <- dsForeigns fords
- ; rules <- mapMaybeM dsRule rules
- ; return ( ds_ev_binds
+ ; (ds_fords, foreign_prs) <- dsForeigns fords
+ ; ds_rules <- mapMaybeM dsRule rules
+ ; ds_vects <- mapM dsVect vects
+ ; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
- , spec_rules ++ rules
+ , spec_rules ++ ds_rules, ds_vects
, ds_fords, ds_hpc_info, modBreaks) }
- ; case mb_res of {
- Nothing -> return (msgs, Nothing) ;
- Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do
+ ; case mb_res of {
+ Nothing -> return (msgs, Nothing) ;
+ Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do
{ -- Add export flags to bindings
keep_alive <- readIORef keep_var
@@ -161,6 +163,7 @@ deSugar hsc_env
mg_foreign = ds_fords,
mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks,
+ mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo
}
; return (msgs, Just mod_guts)
@@ -374,3 +377,26 @@ That keeps the desugaring of list comprehensions simple too.
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
+
+
+%************************************************************************
+%* *
+%* Desugaring vectorisation declarations
+%* *
+%************************************************************************
+
+\begin{code}
+dsVect :: LVectDecl Id -> DsM CoreVect
+dsVect (L loc (HsVect v rhs))
+ = putSrcSpanDs loc $
+ do { rhs' <- fmapMaybeM dsLExpr rhs
+ ; return $ Vect (unLoc v) rhs'
+ }
+-- dsVect (L loc (HsVect v Nothing))
+-- = return $ Vect v Nothing
+-- dsVect (L loc (HsVect v (Just rhs)))
+-- = putSrcSpanDs loc $
+-- do { rhs' <- dsLExpr rhs
+-- ; return $ Vect v (Just rhs')
+-- }
+\end{code}
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4084310638..1781aef5f8 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -368,11 +368,11 @@ dsExpr (ExplicitList elt_ty xs)
-- singletonP x1 +:+ ... +:+ singletonP xn
--
dsExpr (ExplicitPArr ty []) = do
- emptyP <- dsLookupGlobalId emptyPName
+ emptyP <- dsLookupDPHId emptyPName
return (Var emptyP `App` Type ty)
dsExpr (ExplicitPArr ty xs) = do
- singletonP <- dsLookupGlobalId singletonPName
- appP <- dsLookupGlobalId appPName
+ singletonP <- dsLookupDPHId singletonPName
+ appP <- dsLookupDPHId appPName
xs' <- mapM dsLExpr xs
return . foldr1 (binary appP) $ map (unary singletonP) xs'
where
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 2292aedc12..cd22b8ff8c 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -514,7 +514,7 @@ dsPArrComp [ParStmt qss] body _ = -- parallel comprehension
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
dsPArrComp (BindStmt p e _ _ : qs) body _ = do
- filterP <- dsLookupGlobalId filterPName
+ filterP <- dsLookupDPHId filterPName
ce <- dsLExpr e
let ety'ce = parrElemType ce
false = Var falseDataConId
@@ -526,7 +526,7 @@ dsPArrComp (BindStmt p e _ _ : qs) body _ = do
dePArrComp qs body p gen
dsPArrComp qs body _ = do -- no ParStmt in `qs'
- sglP <- dsLookupGlobalId singletonPName
+ sglP <- dsLookupDPHId singletonPName
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
@@ -543,7 +543,7 @@ dePArrComp :: [Stmt Id]
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
dePArrComp [] e' pa cea = do
- mapP <- dsLookupGlobalId mapPName
+ mapP <- dsLookupDPHId mapPName
let ty = parrElemType cea
(clam, ty'e') <- deLambda ty pa e'
return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
@@ -551,7 +551,7 @@ dePArrComp [] e' pa cea = do
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
- filterP <- dsLookupGlobalId filterPName
+ filterP <- dsLookupDPHId filterPName
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
@@ -570,8 +570,8 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
- filterP <- dsLookupGlobalId filterPName
- crossMapP <- dsLookupGlobalId crossMapPName
+ filterP <- dsLookupDPHId filterPName
+ crossMapP <- dsLookupDPHId crossMapPName
ce <- dsLExpr e
let ety'cea = parrElemType cea
ety'ce = parrElemType ce
@@ -595,7 +595,7 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
dePArrComp (LetStmt ds : qs) body pa cea = do
- mapP <- dsLookupGlobalId mapPName
+ mapP <- dsLookupDPHId mapPName
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
v <- newSysLocalDs ty'cea
@@ -640,7 +640,7 @@ dePArrParComp qss body = do
---
parStmts [] pa cea = return (pa, cea)
parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed)
- zipP <- dsLookupGlobalId zipPName
+ zipP <- dsLookupDPHId zipPName
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
res_expr = mkLHsVarTuple xs
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 1238b1a2b5..62e805334e 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -12,15 +12,16 @@ module DsMonad (
foldlM, foldrM, ifDOptM, unsetOptM,
Applicative(..),(<$>),
- newLocalName,
- duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
- newFailLocalDs, newPredVarDs,
- getSrcSpanDs, putSrcSpanDs,
- getModuleDs,
- newUnique,
- UniqSupply, newUniqueSupply,
- getDOptsDs, getGhcModeDs, doptDs,
- dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+ newLocalName,
+ duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
+ newFailLocalDs, newPredVarDs,
+ getSrcSpanDs, putSrcSpanDs,
+ getModuleDs,
+ mkPrintUnqualifiedDs,
+ newUnique,
+ UniqSupply, newUniqueSupply,
+ getDOptsDs, getGhcModeDs, doptDs,
+ dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
dsLookupClass,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
@@ -282,6 +283,9 @@ failWithDs err
; let msg = mkErrMsg loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
; failM }
+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
\end{code}
\begin{code}
@@ -299,6 +303,19 @@ dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= tyThingId <$> dsLookupGlobal name
+-- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
+-- up name is located, varies with the active DPH backend.
+--
+dsLookupDPHId :: (PackageId -> Name) -> DsM Id
+dsLookupDPHId nameInPkg
+ = do { dflags <- getDOpts
+ ; case dphPackageMaybe dflags of
+ Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
+ Nothing -> failWithDs $ ptext err
+ }
+ where
+ err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
+
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
= tyThingTyCon <$> dsLookupGlobal name
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a4a9b80a8f..3a976878e3 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -383,7 +383,7 @@ mkCoAlgCaseMatchResult var ty match_alts
isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
--
mk_parrCase fail = do
- lengthP <- dsLookupGlobalId lengthPName
+ lengthP <- dsLookupDPHId lengthPName
alt <- unboxAlt
return (mkWildCase (len lengthP) intTy ty [alt])
where
@@ -395,7 +395,7 @@ mkCoAlgCaseMatchResult var ty match_alts
--
unboxAlt = do
l <- newSysLocalDs intPrimTy
- indexP <- dsLookupGlobalId indexPName
+ indexP <- dsLookupDPHId indexPName
alts <- mapM (mkAlt indexP) sorted_alts
return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
where
View Lorry Controller Status