diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Check.hs | 5 | ||||
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 8 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 42 | ||||
| -rw-r--r-- | compiler/deSugar/DsArrows.hs | 1 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 27 | ||||
| -rw-r--r-- | compiler/deSugar/DsListComp.hs | 210 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 11 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 166 | ||||
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 78 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 9 | ||||
| -rw-r--r-- | compiler/deSugar/MatchCon.hs | 6 | ||||
| -rw-r--r-- | compiler/deSugar/PmExpr.hs | 12 |
12 files changed, 15 insertions, 560 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 39f585394a..d5449f373a 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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)) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 25b77f2cfe..ac02989572 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index ce12a5631a..2f3fead184 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 5e355f03f9..c69d7495d9 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -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 diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 7ee1857dfe..b6337e4d45 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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 ~~~~~~~~~~~~~~~ diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 8c9fa72e03..29b3cf42ab 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -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 --- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) --- -dePArrComp (BindStmt _ p e _ _ : qs) pa cea = do - filterP <- dsDPHBuiltin filterPVar - crossMapP <- dsDPHBuiltin crossMapPVar - ce <- dsLExpr e - let ety'cea = parrElemType cea - ety'ce = parrElemType ce - false = Var falseDataConId - true = Var trueDataConId - v <- newSysLocalDs ety'ce - pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false - let cef | isIrrefutableHsPat p = ce - | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - (clam, _) <- mkLambda ety'cea pa cef - let ety'cef = ety'ce -- filter doesn't change the element type - pa' = mkLHsPatTup [pa, p] - - dePArrComp qs pa' (mkApps (Var crossMapP) - [Type ety'cea, Type ety'cef, cea, clam]) --- --- <<[:e' | let ds, qs:]>> pa ea = --- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) --- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea) --- where --- {x_1, ..., x_n} = DV (ds) -- Defined Variables --- -dePArrComp (LetStmt _ lds@(L _ ds) : qs) pa cea = do - mapP <- dsDPHBuiltin mapPVar - let xs = collectLocalBinders ds - ty'cea = parrElemType cea - v <- newSysLocalDs ty'cea - clet <- dsLocalBinds lds (mkCoreTup (map Var xs)) - let'v <- newSysLocalDs (exprType clet) - let projBody = mkCoreLet (NonRec let'v clet) $ - mkCoreTup [Var v, Var let'v] - errTy = exprType projBody - errMsg = text "DsListComp.dePArrComp: internal error!" - cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg - ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr - let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] - proj = mkLams [v] ccase - dePArrComp qs pa' (mkApps (Var mapP) - [Type ty'cea, Type errTy, proj, cea]) --- --- The parser guarantees that parallel comprehensions can only appear as --- singleton qualifier lists, which we already special case in the caller. --- So, encountering one here is a bug. --- -dePArrComp (ParStmt {} : _) _ _ = - panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt" -dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt" -dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt" -dePArrComp (ApplicativeStmt {} : _) _ _ = - panic "DsListComp.dePArrComp: ApplicativeStmt" -dePArrComp (XStmtLR {} : _) _ _ = - panic "DsListComp.dePArrComp: XStmtLR" - --- <<[:e' | qs | qss:]>> pa ea = --- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) --- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) --- where --- {x_1, ..., x_n} = DV (qs) --- -dePArrParComp :: [ParStmtBlock GhcTc GhcTc] -> [ExprStmt GhcTc] -> DsM CoreExpr -dePArrParComp qss quals = do - (pQss, ceQss) <- deParStmt qss - dePArrComp quals pQss ceQss - where - deParStmt [] = - -- empty parallel statement lists have no source representation - panic "DsListComp.dePArrComp: Empty parallel list comprehension" - deParStmt (ParStmtBlock _ qs xs _:qss) = do -- first statement - let res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) - parStmts qss (mkLHsVarPatTup xs) cqs - deParStmt (XParStmtBlock{}:_) = panic "dePArrParComp" - --- - parStmts [] pa cea = return (pa, cea) - parStmts (ParStmtBlock _ qs xs _:qss) pa cea = do - -- subsequent statements (zip'ed) - zipP <- dsDPHBuiltin zipPVar - let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] - ty'cea = parrElemType cea - res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) - let ty'cqs = parrElemType cqs - cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] - parStmts qss pa' cea' - parStmts (XParStmtBlock{}:_) _ _ = panic "dePArrParComp" - --- generate Core corresponding to `\p -> e' --- -deLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat GhcTc -- argument pattern - -> LHsExpr GhcTc -- body - -> DsM (CoreExpr, Type) -deLambda ty p e = - mkLambda ty p =<< dsLExpr e - --- generate Core for a lambda pattern match, where the body is already in Core --- -mkLambda :: Type -- type of the argument (not levity-polymorphic) - -> LPat GhcTc -- argument pattern - -> CoreExpr -- desugared body - -> DsM (CoreExpr, Type) -mkLambda ty p ce = do - v <- newSysLocalDs ty - let errMsg = text "DsListComp.deLambda: internal error!" - ce'ty = exprType ce - cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg - res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr - return (mkLams [v] res, ce'ty) - --- obtain the element type of the parallel array produced by the given Core --- expression --- -parrElemType :: CoreExpr -> Type -parrElemType e = - case splitTyConApp_maybe (exprType e) of - Just (tycon, [ty]) | tycon == parrTyCon -> ty - _ -> panic - "DsListComp.parrElemType: not a parallel array type" - -- Translation for monad comprehensions -- Entry point for monad comprehension desugaring diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 6bff89774d..cc1bd3d799 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -121,7 +121,6 @@ repTopDs group@(HsGroup { hs_valds = valds , hs_warnds = warnds , hs_annds = annds , hs_ruleds = ruleds - , hs_vects = vects , hs_docs = docs }) = do { let { bndrs = hsSigTvBinders valds ++ hsGroupBinders group @@ -151,7 +150,6 @@ repTopDs group@(HsGroup { hs_valds = valds ; ann_ds <- mapM repAnnD annds ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) ruleds) - ; _ <- mapM no_vect vects ; _ <- mapM no_doc docs -- more needed @@ -178,8 +176,6 @@ repTopDs group@(HsGroup { hs_valds = valds = notHandledL loc "WARNING and DEPRECATION pragmas" $ text "Pragma for declaration of" <+> ppr thing no_warn (L _ (XWarnDecl _)) = panic "repTopDs" - no_vect (L loc decl) - = notHandledL loc "Vectorisation pragmas" (ppr decl) no_doc (L loc _) = notHandledL loc "Haddock documentation" empty repTopDs (XHsGroup _) = panic "repTopDs" @@ -1114,11 +1110,6 @@ repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 -repTy (HsPArrTy _ t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar noExt NotPromoted - (noLoc (tyConName parrTyCon))) - repTapp tcon t1 repTy (HsTupleTy _ HsUnboxedTuple tys) = do tys1 <- repLTys tys tcon <- repUnboxedTupleTyCon (length tys) @@ -1291,7 +1282,6 @@ repE e@(HsDo _ ctxt (L _ sts)) = notHandled "mdo, monad comprehension and [: :]" (ppr e) repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } -repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple _ es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs } @@ -1340,7 +1330,6 @@ repE (HsUnboundVar _ uv) = do sname <- repNameS occ repUnboundVar sname -repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index d075d0a118..c26854f479 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -23,13 +23,9 @@ module DsMonad ( newUnique, UniqSupply, newUniqueSupply, getGhcModeDs, dsGetFamInstEnvs, - dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, + dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, - PArrBuiltin(..), - dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, - dsInitPArrBuiltin, - DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -- Getting and setting EvVars and term constraints in local environment @@ -65,8 +61,6 @@ import CoreUtils ( exprType, isExprLevPoly ) import HsSyn import TcIface import TcMType ( checkForLevPolyX, formatLevPolyErr ) -import LoadIface -import Finder import PrelNames import RdrName import HscTypes @@ -86,15 +80,12 @@ import NameEnv import DynFlags import ErrUtils import FastString -import Maybes import Var (EvVar) -import qualified GHC.LanguageExtensions as LangExt import UniqFM ( lookupWithDefaultUFM ) import Literal ( mkMachString ) import CostCentreState import Data.IORef -import Control.Monad {- ************************************************************************ @@ -166,7 +157,7 @@ initDsTc thing_inside ; msg_var <- getErrsVar ; hsc_env <- getTopEnv ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - ; setEnvs envs $ initDPH thing_inside + ; setEnvs envs thing_inside } -- | Run a 'DsM' action inside the 'IO' monad. @@ -198,7 +189,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl - (initDPH $ tryM thing_inside) + (tryM thing_inside) ; msgs <- readIORef (ds_msgs ds_gbl) ; let final_res | errorsFound dflags msgs = Nothing @@ -271,8 +262,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var , ds_if_env = (if_genv, if_lenv) , ds_unqual = mkPrintUnqualified dflags rdr_env , ds_msgs = msg_var - , ds_dph_env = emptyGlobalRdrEnv - , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" , ds_complete_matches = completeMatchMap , ds_cc_st = cc_st_var } @@ -500,23 +489,6 @@ mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal --- | Attempt to load the given module and return its exported entities if --- successful. -dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv -dsLoadModule doc mod - = do { env <- getGblEnv - ; setEnvs (ds_if_env env) $ do - { iface <- loadInterface doc mod ImportBySystem - ; case iface of - Failed err -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc) - Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface - } } - where - prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll }) - imp_spec = ImpDeclSpec { is_mod = name, is_qual = True, - is_dloc = wiredInSrcSpan, is_as = name } - name = moduleName mod - dsLookupGlobal :: Name -> DsM TyThing -- Very like TcEnv.tcLookupGlobal dsLookupGlobal name @@ -609,138 +581,6 @@ dsWhenNoErrs thing_inside mk_expr then mk_expr result else unitExpr } --------------------------------------------------------------------------- --- Data Parallel Haskell --------------------------------------------------------------------------- - --- | Run a 'DsM' with DPH things in scope if necessary. -initDPH :: DsM a -> DsM a -initDPH = loadDAP . initDPHBuiltins - --- | Extend the global environment with a 'GlobalRdrEnv' containing the exported --- entities of, --- --- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP'). --- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. -loadDAP :: DsM a -> DsM a -loadDAP thing_inside - = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr - ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr - ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside - } - where - loadOneModule :: ModuleName -- the module to load - -> DsM Bool -- under which condition - -> MsgDoc -- error message if module not found - -> DsM GlobalRdrEnv -- empty if condition 'False' - loadOneModule modname check err - = do { doLoad <- check - ; if not doLoad - then return emptyGlobalRdrEnv - else do { - ; hsc_env <- getTopEnv - ; result <- liftIO $ findImportedModule hsc_env modname Nothing - ; case result of - Found _ mod -> dsLoadModule err mod - _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err - } } - - paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2 - veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2 - specBackend = text "you must specify a DPH backend package" - hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'" - hint2 = text "You may need to install them with 'cabal install dph-examples'" - --- | If '-XParallelArrays' given, we populate the builtin table for desugaring --- those. -initDPHBuiltins :: DsM a -> DsM a -initDPHBuiltins thing_inside - = do { doInitBuiltins <- checkLoadDAP - ; if doInitBuiltins - then dsInitPArrBuiltin thing_inside - else thing_inside - } - -checkLoadDAP :: DsM Bool -checkLoadDAP - = do { paEnabled <- xoptM LangExt.ParallelArrays - ; mod <- getModule - -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a - -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top - -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries - ; return $ paEnabled && - mod /= gHC_PARR' && - moduleName mod /= dATA_ARRAY_PARALLEL_NAME - } - --- | Populate 'ds_parr_bi' from 'ds_dph_env'. --- -dsInitPArrBuiltin :: DsM a -> DsM a -dsInitPArrBuiltin thing_inside - = do { lengthPVar <- externalVar (fsLit "lengthP") - ; replicatePVar <- externalVar (fsLit "replicateP") - ; singletonPVar <- externalVar (fsLit "singletonP") - ; mapPVar <- externalVar (fsLit "mapP") - ; filterPVar <- externalVar (fsLit "filterP") - ; zipPVar <- externalVar (fsLit "zipP") - ; crossMapPVar <- externalVar (fsLit "crossMapP") - ; indexPVar <- externalVar (fsLit "!:") - ; emptyPVar <- externalVar (fsLit "emptyP") - ; appPVar <- externalVar (fsLit "+:+") - -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP") - -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP") - ; enumFromToPVar <- return arithErr - ; enumFromThenToPVar <- return arithErr - - ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin - { lengthPVar = lengthPVar - , replicatePVar = replicatePVar - , singletonPVar = singletonPVar - , mapPVar = mapPVar - , filterPVar = filterPVar - , zipPVar = zipPVar - , crossMapPVar = crossMapPVar - , indexPVar = indexPVar - , emptyPVar = emptyPVar - , appPVar = appPVar - , enumFromToPVar = enumFromToPVar - , enumFromThenToPVar = enumFromThenToPVar - } }) - thing_inside - } - where - externalVar :: FastString -> DsM Var - externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId - - arithErr = panic "Arithmetic sequences have to wait until we support type classes" - --- |Get a name from "Data.Array.Parallel" for the desugarer, from the --- 'ds_parr_bi' component of the global desugerar environment. --- -dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a -dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv - --- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'. --- Panic if there isn't one, or if it is defined multiple times. -dsLookupDPHRdrEnv :: OccName -> DsM Name -dsLookupDPHRdrEnv occ - = liftM (fromMaybe (pprPanic nameNotFound (ppr occ))) - $ dsLookupDPHRdrEnv_maybe occ - where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':" - --- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim', --- returning `Nothing` if it's not defined. Panic if it's defined multiple times. -dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name) -dsLookupDPHRdrEnv_maybe occ - = do { env <- ds_dph_env <$> getGblEnv - ; let gres = lookupGlobalRdrEnv env occ - ; case gres of - [] -> return $ Nothing - [gre] -> return $ Just $ gre_name gre - _ -> pprPanic multipleNames (ppr occ) - } - where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':" - -- | Inject a trace message into the compiled program. Whereas -- pprTrace prints out information *while compiling*, pprRuntimeTrace -- captures that information and causes it to be printed *at runtime* diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 7bec30acdc..4c30889858 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -282,18 +282,15 @@ data CaseAlt a = MkCaseAlt{ alt_pat :: a, alt_result :: MatchResult } mkCoAlgCaseMatchResult - :: DynFlags - -> Id -- Scrutinee + :: Id -- Scrutinee -> Type -- Type of exp -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts) -> MatchResult -mkCoAlgCaseMatchResult dflags var ty match_alts +mkCoAlgCaseMatchResult var ty match_alts | isNewtype -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1 - | isPArrFakeAlts match_alts - = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts) | otherwise = mkDataConCase var ty match_alts where @@ -311,34 +308,6 @@ mkCoAlgCaseMatchResult dflags var ty match_alts -- (not that splitTyConApp does, these days) newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) - --- Stuff for parallel arrays - -- - -- Concerning `isPArrFakeAlts': - -- - -- * it is *not* sufficient to just check the type of the type - -- constructor, as we have to be careful not to confuse the real - -- representation of parallel arrays with the fake constructors; - -- moreover, a list of alternatives must not mix fake and real - -- constructors (this is checked earlier on) - -- - -- FIXME: We actually go through the whole list and make sure that - -- either all or none of the constructors are fake parallel - -- array constructors. This is to spot equations that mix fake - -- constructors with the real representation defined in - -- `PrelPArr'. It would be nicer to spot this situation - -- earlier and raise a proper error message, but it can really - -- only happen in `PrelPArr' anyway. - -- - - isPArrFakeAlts :: [CaseAlt DataCon] -> Bool - isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt) - isPArrFakeAlts (alt:alts) = - case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of - (True , True ) -> True - (False, False) -> False - _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns" - isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" - mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt @@ -412,49 +381,6 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case = mkUniqSet data_cons `minusUniqSet` mentioned_constructors exhaustive_case = isEmptyUniqSet un_mentioned_constructors ---- Stuff for parallel arrays --- --- * the following is to desugar cases over fake constructors for --- parallel arrays, which are introduced by `tidy1' in the `PArrPat' --- case --- -mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr - -> DsM CoreExpr -mkPArrCase dflags var ty sorted_alts fail = do - lengthP <- dsDPHBuiltin lengthPVar - alt <- unboxAlt - return (mkWildCase (len lengthP) intTy ty [alt]) - where - elemTy = case splitTyConApp (idType var) of - (_, [elemTy]) -> elemTy - _ -> panic panicMsg - panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" - len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] - -- - unboxAlt = do - l <- newSysLocalDs intPrimTy - indexP <- dsDPHBuiltin indexPVar - alts <- mapM (mkAlt indexP) sorted_alts - return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) - where - dft = (DEFAULT, [], fail) - - -- - -- each alternative matches one array length (corresponding to one - -- fake array constructor), so the match is on a literal; each - -- alternative's body is extended by a local binding for each - -- constructor argument, which are bound to array elements starting - -- with the first - -- - mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do - body <- bodyFun fail - return (LitAlt lit, [], mkCoreLets binds body) - where - lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt)) - binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)] - -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i] - {- ************************************************************************ * * diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 6b548a4f5a..fabbe2bc2f 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -448,14 +448,6 @@ tidy1 _ (ListPat (ListPatTc ty Nothing) pats ) (mkNilPat ty) pats --- Introduce fake parallel array constructors to be able to handle parallel --- arrays with the existing machinery for constructor pattern -tidy1 _ (PArrPat ty pats) - = return (idDsWrapper, unLoc parrConPat) - where - arity = length pats - parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty] - tidy1 _ (TuplePat tys pats boxity) = return (idDsWrapper, unLoc tuple_ConPat) where @@ -498,7 +490,6 @@ tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p tidy_bang_pat v _ p@(SumPat {}) = tidy1 v p -tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p -- Data/newtype constructors tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc) diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 5bf8c066f4..49586bc972 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -29,7 +29,6 @@ import Id import NameEnv import FieldLabel ( flSelector ) import SrcLoc -import DynFlags import Outputable import Control.Monad(liftM) import Data.List (groupBy) @@ -93,9 +92,8 @@ matchConFamily :: [Id] -> DsM MatchResult -- Each group of eqns is for a single constructor matchConFamily (var:vars) ty groups - = do dflags <- getDynFlags - alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups - return (mkCoAlgCaseMatchResult dflags var ty alts) + = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups + return (mkCoAlgCaseMatchResult var ty alts) where toRealAlt alt = case alt_pat alt of RealDataCon dcon -> alt{ alt_pat = dcon } diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index f008a31d4b..56d310f618 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -261,10 +261,6 @@ hsExprToPmExpr e@(ExplicitList _ mb_ol elems) cons x xs = mkPmExprData consDataCon [x,xs] nil = mkPmExprData nilDataCon [] -hsExprToPmExpr (ExplicitPArr _ elems) - = mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems) - - -- we want this but we would have to make everything monadic :/ -- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon -- @@ -395,7 +391,7 @@ needsParens (PmExprLit l) = isNegatedPmLit l needsParens (PmExprEq {}) = False -- will become a wildcard needsParens (PmExprOther {}) = False -- will become a wildcard needsParens (PmExprCon (RealDataCon c) es) - | isTupleDataCon c || isPArrFakeCon c + | isTupleDataCon c || isConsDataCon c || null es = False | otherwise = True needsParens (PmExprCon (PatSynCon _) es) = not (null es) @@ -408,12 +404,10 @@ pprPmExprWithParens expr pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc pprPmExprCon (RealDataCon con) args | isTupleDataCon con = mkTuple <$> mapM pprPmExpr args - | isPArrFakeCon con = mkPArr <$> mapM pprPmExpr args - | isConsDataCon con = pretty_list + | isConsDataCon con = pretty_list where - mkTuple, mkPArr :: [SDoc] -> SDoc + mkTuple :: [SDoc] -> SDoc mkTuple = parens . fsep . punctuate comma - mkPArr = paBrackets . fsep . punctuate comma -- lazily, to be used in the list case only pretty_list :: PmPprM SDoc |