diff options
Diffstat (limited to 'compiler')
52 files changed, 550 insertions, 271 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 281ae938ed..e11262568e 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -73,6 +73,7 @@ module Name ( #include "Typeable.h" import {-# SOURCE #-} TypeRep( TyThing ) +import {-# SOURCE #-} PrelNames( liftedTypeKindTyConKey ) import OccName import Module @@ -566,7 +567,26 @@ getOccString = occNameString . getOccName pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc -- See Outputable.pprPrefixVar, pprInfixVar; -- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) -pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n) +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName thing + | name `hasKey` liftedTypeKindTyConKey + = ppr name -- See Note [Special treatment for kind *] + | otherwise + = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing \end{code} +Note [Special treatment for kind *] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not put parens around the kind '*'. Even though it looks like +an operator, it is really a special case. + +This pprPrefixName stuff is really only used when printing HsSyn, +which has to be polymorphic in the name type, and hence has to go via +the overloaded function pprPrefixOcc. It's easier where we know the +type being pretty printed; eg the pretty-printing code in TypeRep. + +See Trac #7645, which led to this. + diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 3ff3bbb82f..ff98923eb8 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -277,7 +277,11 @@ instance OutputableBndr RdrName where | otherwise = ppr n pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 4005f6d9b4..05ef2b270c 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -880,6 +880,10 @@ translateOp dflags IntLeOp = Just (mo_wordSLe dflags) translateOp dflags IntGtOp = Just (mo_wordSGt dflags) translateOp dflags IntLtOp = Just (mo_wordSLt dflags) +translateOp dflags AndIOp = Just (mo_wordAnd dflags) +translateOp dflags OrIOp = Just (mo_wordOr dflags) +translateOp dflags XorIOp = Just (mo_wordXor dflags) +translateOp dflags NotIOp = Just (mo_wordNot dflags) translateOp dflags ISllOp = Just (mo_wordShl dflags) translateOp dflags ISraOp = Just (mo_wordSShr dflags) translateOp dflags ISrlOp = Just (mo_wordUShr dflags) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 2932b01822..081960466f 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -141,8 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p) untidy' _ (LitPat lit) = LitPat (untidy_lit lit) untidy' _ p@(ConPatIn _ (PrefixCon [])) = p untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) - untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty + untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty + untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat" @@ -568,15 +569,15 @@ is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon is_nil _ = False is_list :: Pat Name -> Bool -is_list (ListPat _ _) = True +is_list (ListPat _ _ Nothing) = True is_list _ = False return_list :: DataCon -> Pat Name -> Bool return_list id q = id == consDataCon && (is_nil q || is_list q) make_list :: LPat Name -> Pat Name -> Pat Name -make_list p q | is_nil q = ListPat [p] placeHolderType -make_list p (ListPat ps ty) = ListPat (p:ps) ty +make_list p q | is_nil q = ListPat [p] placeHolderType Nothing +make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat @@ -647,7 +648,8 @@ might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p) might_fail_pat (ParPat p) = might_fail_lpat p might_fail_pat (AsPat _ p) = might_fail_lpat p might_fail_pat (SigPatOut p _ ) = might_fail_lpat p -might_fail_pat (ListPat ps _) = any might_fail_lpat ps +might_fail_pat (ListPat ps _ Nothing) = any might_fail_lpat ps +might_fail_pat (ListPat _ _ (Just _)) = True might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps might_fail_pat (PArrPat ps _) = any might_fail_lpat ps might_fail_pat (BangPat p) = might_fail_lpat p @@ -682,11 +684,12 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat -- guard says "this equation might fall through". tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (ViewPat _ _ ty) = WildPat ty +tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) = pat { pat_args = tidy_con id ps } -tidy_pat (ListPat ps ty) +tidy_pat (ListPat ps ty Nothing) = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) (mkNilPat list_ty) (map tidy_lpat ps) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 5cd85139e2..bdcf9c9f78 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -519,10 +519,14 @@ addTickHsExpr (HsDo cxt stmts srcloc) forQual = case cxt of ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpr (ExplicitList ty es) = - liftM2 ExplicitList +addTickHsExpr (ExplicitList ty wit es) = + liftM3 ExplicitList (return ty) - (mapM (addTickLHsExpr) es) + (addTickWit wit) + (mapM (addTickLHsExpr) es) + where addTickWit Nothing = return Nothing + addTickWit (Just fln) = do fln' <- addTickHsExpr fln + return (Just fln') addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) @@ -543,10 +547,14 @@ addTickHsExpr (ExprWithTySigOut e ty) = (addTickLHsExprNever e) -- No need to tick the inner expression -- for expressions with signatures (return ty) -addTickHsExpr (ArithSeq ty arith_seq) = - liftM2 ArithSeq +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq (return ty) + (addTickWit wit) (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickHsExpr fl + return (Just fl') addTickHsExpr (HsTickPragma _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 76f167d0f4..b825acb836 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -1155,7 +1155,7 @@ collectl (L _ pat) bndrs go (AsPat (L _ a) pat) = a : collectl pat bndrs go (ParPat pat) = collectl pat bndrs - go (ListPat pats _) = foldr collectl bndrs pats + go (ListPat pats _ _) = foldr collectl bndrs pats go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index cfda20adda..226eee27bd 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -350,8 +350,8 @@ dsExpr (HsMultiIf res_ty alts) \underline{\bf Various data construction things} % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -dsExpr (ExplicitList elt_ty xs) - = dsExplicitList elt_ty xs +dsExpr (ExplicitList elt_ty wit xs) + = dsExplicitList elt_ty wit xs -- We desugar [:x1, ..., xn:] as -- singletonP x1 +:+ ... +:+ singletonP xn @@ -368,17 +368,13 @@ dsExpr (ExplicitPArr ty xs) = do unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] -dsExpr (ArithSeq expr (From from)) - = App <$> dsExpr expr <*> dsLExpr from - -dsExpr (ArithSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] - -dsExpr (ArithSeq expr (FromThen from thn)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] - -dsExpr (ArithSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] +dsExpr (ArithSeq expr witness seq) + = case witness of + Nothing -> dsArithSeq expr seq + Just fl -> do { + ; fl' <- dsExpr fl + ; newArithSeq <- dsArithSeq expr seq + ; return (App fl' newArithSeq)} dsExpr (PArrSeq expr (FromTo from to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] @@ -673,9 +669,9 @@ makes all list literals be generated via the simple route. \begin{code} -dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr +dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] -dsExplicitList elt_ty xs +dsExplicitList elt_ty Nothing xs = do { dflags <- getDynFlags ; xs' <- mapM dsLExpr xs ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' @@ -700,9 +696,25 @@ dsExplicitList elt_ty xs ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' ; return (foldr (App . App (Var c)) folded_suffix prefix) } +dsExplicitList elt_ty (Just fln) xs + = do { fln' <- dsExpr fln + ; list <- dsExplicitList elt_ty Nothing xs + ; dflags <- getDynFlags + ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) } + spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail f xs = (reverse rejected, reverse satisfying) where (satisfying, rejected) = span f $ reverse xs + +dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr +dsArithSeq expr (From from) + = App <$> dsExpr expr <*> dsLExpr from +dsArithSeq expr (FromTo from to) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] +dsArithSeq expr (FromThen from thn) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] +dsArithSeq expr (FromThenTo from thn to) + = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] \end{code} Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4f5ba2df17..ae7a3cc271 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -970,7 +970,7 @@ repE e@(HsDo ctxt sts _) | otherwise = notHandled "mdo, monad comprehension and [: :]" (ppr e) -repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } +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) @@ -987,7 +987,7 @@ repE (RecordUpd e flds _ _ _) repRecUpd x fs } repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } -repE (ArithSeq _ aseq) = +repE (ArithSeq _ _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do @@ -1259,7 +1259,8 @@ repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p -repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } +repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p} repP (TuplePat ps boxed _) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 5b0f3b1ff6..43a3af7a4c 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -17,7 +17,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat #include "HsVersions.h" -import {-#SOURCE#-} DsExpr (dsLExpr) +import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr) import DynFlags import HsSyn @@ -53,7 +53,7 @@ import qualified Data.Map as Map \end{code} This function is a wrapper of @match@, it must be called from all the parts where -it was called match, but only substitutes the firs call, .... +it was called match, but only substitutes the first call, .... if the associated flags are declared, warnings will be issued. It can not be called matchWrapper because this name already exists :-( @@ -327,12 +327,13 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty PgBang -> matchBangs vars ty (dropGroup eqns) PgCo _ -> matchCoercion vars ty (dropGroup eqns) PgView _ _ -> matchView vars ty (dropGroup eqns) - + PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) + -- FIXME: we should also warn about view patterns that should be -- commoned up but are not -- print some stuff to see what's getting grouped - -- use -dppr-debug to see the resolution of overloaded lits + -- use -dppr-debug to see the resolution of overloaded literals debug eqns = let gs = map (\group -> foldr (\ (p,_) -> \acc -> case p of PgView e _ -> e:acc @@ -391,19 +392,33 @@ matchView (var:vars) ty (eqns@(eqn1:_)) ; return (mkViewMatchResult var' viewExpr' var match_result) } matchView _ _ _ = panic "matchView" +matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) +-- Since overloaded list patterns are treated as view patterns, +-- the code is roughly the same as for matchView + = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand + ; match_result <- match (var':vars) ty $ + map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern + ; e' <- dsExpr e + ; return (mkViewMatchResult var' e' var match_result) } +matchOverloadedList _ _ _ = panic "matchOverloadedList" + -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" -getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id +getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id getCoPat (CoPat _ pat _) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat pat ) = unLoc pat getBangPat _ = panic "getBangPat" getViewPat (ViewPat _ pat _) = unLoc pat -getViewPat _ = panic "getBangPat" +getViewPat _ = panic "getViewPat" +getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing +getOLPat _ = panic "getOLPat" \end{code} Note [Empty case alternatives] @@ -536,7 +551,7 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } -tidy1 _ (ListPat pats ty) +tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty @@ -831,7 +846,8 @@ data PatGroup | PgView (LHsExpr Id) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) - + | PgOverloadedList + groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg @@ -885,7 +901,7 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 -- always have the same type, so this boils down to saying that -- the two coercions are identical. sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) - -- ViewPats are in the same gorup iff the expressions + -- ViewPats are in the same group iff the expressions -- are "equal"---conservatively, we use syntactic equality sameGroup _ _ = False @@ -1002,6 +1018,7 @@ patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) +patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 9621f1de4b..fe6779bd01 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -24,14 +24,19 @@ compiler_stage3_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES compiler_stage1_C_FILES_NODEPS = compiler/parser/cutils.c +# This package doesn't pass the Cabal checks because include-dirs +# points outside the source directory. This isn't a real problem, so +# we just skip the check. +compiler_NO_CHECK = YES + ifneq "$(BINDIST)" "YES" compiler/stage1/package-data.mk : compiler/stage1/build/Config.hs compiler/stage2/package-data.mk : compiler/stage2/build/Config.hs compiler/stage3/package-data.mk : compiler/stage3/build/Config.hs -compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) -compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) -compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage1/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage2/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) +compiler/stage3/build/PlatformConstants.o: $(includes_GHCCONSTANTS_HASKELL_TYPE) compiler/stage1/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) compiler/stage2/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) compiler/stage3/build/DynFlags.o: $(includes_GHCCONSTANTS_HASKELL_EXPORTS) @@ -253,7 +258,6 @@ compiler/stage$1/build/Parser.y: compiler/parser/Parser.y.pp compiler/stage$1/build/primops.txt: compiler/prelude/primops.txt.pp compiler/stage$1/$$(PLATFORM_H) $$(CPP) $$(RAWCPP_FLAGS) -P $$(compiler_CPP_OPTS) -Icompiler/stage$1 -x c $$< | grep -v '^#pragma GCC' > $$@ -ifneq "$$(BootingFromHc)" "YES" compiler/stage$1/build/primop-data-decl.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE) "$$(GENPRIMOP_INPLACE)" --data-decl < $$< > $$@ compiler/stage$1/build/primop-tag.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE) @@ -281,7 +285,6 @@ compiler/stage$1/build/primop-primop-info.hs-incl: compiler/stage$1/build/primop # can still generate them if we want them back compiler/stage$1/build/primop-usage.hs-incl: compiler/stage$1/build/primops.txt $$(GENPRIMOP_INPLACE) "$$(GENPRIMOP_INPLACE)" --usage < $$< > $$@ -endif endef @@ -490,11 +493,11 @@ $(compiler_stage1_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STA $(compiler_stage2_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE2) $(compiler_stage3_depfile_haskell) : $(COMPILER_INCLUDES_DEPS) $(PRIMOP_BITS_STAGE3) -$(foreach way,$$(compiler_stage1_WAYS),\ +$(foreach way,$(compiler_stage1_WAYS),\ compiler/stage1/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE1) -$(foreach way,$$(compiler_stage2_WAYS),\ +$(foreach way,$(compiler_stage2_WAYS),\ compiler/stage2/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE2) -$(foreach way,$$(compiler_stage3_WAYS),\ +$(foreach way,$(compiler_stage3_WAYS),\ compiler/stage3/build/PrimOp.$($(way)_osuf)) : $(PRIMOP_BITS_STAGE3) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index ce15071439..8caf987336 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -545,11 +545,11 @@ cvtl e = wrapL (cvt e) ; return $ HsCase e' (mkMatchGroup ms') } cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss - cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' } + cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- Note [Converting strings] - | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } + | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void Nothing xs' } -- Infix expressions cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y @@ -806,7 +806,7 @@ cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } -cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } +cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t ; return $ SigPatIn p' (mkHsWithBndrs t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 32218e5393..ce391c73e2 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -4,7 +4,8 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} -- | Abstract syntax of global declarations. -- @@ -15,7 +16,8 @@ module HsDecls ( HsDecl(..), LHsDecl, HsDataDefn(..), -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup, - isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, tcdName, + isClassDecl, isDataDecl, isSynDecl, tcdName, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, tyFamInstDeclName, tyFamInstDeclLName, countTyClDecls, pprTyClDeclFlavour, tyClDeclLName, tyClDeclTyVars, @@ -53,7 +55,7 @@ module HsDecls ( WarnDecl(..), LWarnDecl, -- ** Annotations AnnDecl(..), LAnnDecl, - AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM, + AnnProvenance(..), annProvenanceName_maybe, -- * Grouping HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups @@ -83,8 +85,9 @@ import SrcLoc import FastString import Bag -import Control.Monad ( liftM ) import Data.Data hiding (TyCon) +import Data.Foldable (Foldable) +import Data.Traversable \end{code} %************************************************************************ @@ -476,7 +479,7 @@ data FamilyDecl name = FamilyDecl data FamilyFlavour = TypeFamily | DataFamily - deriving( Data, Typeable ) + deriving( Data, Typeable, Eq ) \end{code} @@ -500,10 +503,20 @@ isClassDecl :: TyClDecl name -> Bool isClassDecl (ClassDecl {}) = True isClassDecl _ = False --- | type family declaration +-- | type/data family declaration isFamilyDecl :: TyClDecl name -> Bool isFamilyDecl (FamDecl {}) = True isFamilyDecl _other = False + +-- | type family declaration +isTypeFamilyDecl :: TyClDecl name -> Bool +isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily +isTypeFamilyDecl _other = False + +-- | data family declaration +isDataFamilyDecl :: TyClDecl name -> Bool +isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily +isDataFamilyDecl _other = False \end{code} Dealing with names @@ -1348,21 +1361,13 @@ instance (OutputableBndr name) => Outputable (AnnDecl name) where data AnnProvenance name = ValueAnnProvenance name | TypeAnnProvenance name | ModuleAnnProvenance - deriving (Data, Typeable) + deriving (Data, Typeable, Functor, Foldable, Traversable) annProvenanceName_maybe :: AnnProvenance name -> Maybe name annProvenanceName_maybe (ValueAnnProvenance name) = Just name annProvenanceName_maybe (TypeAnnProvenance name) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing --- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough -modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after) -modifyAnnProvenanceNameM fm prov = - case prov of - ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name) - TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name) - ModuleAnnProvenance -> return ModuleAnnProvenance - pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module") pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 3e3c2f4ed0..d59c193ae8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -179,8 +179,9 @@ data HsExpr id [ExprLStmt id] -- "do":one or more stmts PostTcType -- Type of the whole expression - | ExplicitList -- syntactic list - PostTcType -- Gives type of components of list + | ExplicitList -- syntactic list + PostTcType -- Gives type of components of list + (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness [LHsExpr id] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] @@ -215,8 +216,9 @@ data HsExpr id (LHsType Name) -- Retain the signature for -- round-tripping purposes - | ArithSeq -- arithmetic sequence + | ArithSeq -- Arithmetic sequence PostTcExpr + (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness (ArithSeqInfo id) | PArrSeq -- arith. sequence for parallel array @@ -500,7 +502,7 @@ ppr_expr (HsLet binds expr) ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts -ppr_expr (ExplicitList _ exprs) +ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) @@ -519,7 +521,7 @@ ppr_expr (ExprWithTySigOut expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) -ppr_expr (ArithSeq _ info) = brackets (ppr info) +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr EWildPat = char '_' diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 64bda890db..3a8e433596 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -67,8 +67,12 @@ data Pat id | BangPat (LPat id) -- Bang pattern ------------ Lists, tuples, arrays --------------- - | ListPat [LPat id] -- Syntactic list - PostTcType -- The type of the elements + | ListPat [LPat id] -- Syntactic list + PostTcType -- The type of the elements + (Maybe (PostTcType, SyntaxExpr id)) -- For rebindable syntax + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList + -- function to convert the scrutinee to a list value | TuplePat [LPat id] -- Tuple Boxity -- UnitPat is TuplePat [] @@ -245,7 +249,7 @@ pprPat (BangPat pat) = char '!' <> pprParendLPat pat pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) -pprPat (ListPat pats _) = brackets (interpp'SP pats) +pprPat (ListPat pats _ _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) @@ -401,7 +405,7 @@ isIrrefutableHsPat pat go1 (SigPatIn pat _) = go pat go1 (SigPatOut pat _) = go pat go1 (TuplePat pats _ _) = all go pats - go1 (ListPat {}) = False + go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? go1 (ConPatIn {}) = False -- Conservative diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 74aa4773b6..d0d9e1a0a9 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -614,7 +614,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty pREC_CON ty ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds -ppr_mono_ty _ (HsTyVar name) = ppr name +ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) where std_con = case con of diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 081d61be10..1fa949653e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -343,7 +343,7 @@ nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (mkHsIf cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) -nlList exprs = noLoc (ExplicitList placeHolderType exprs) +nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsTyVar :: name -> LHsType name @@ -569,7 +569,7 @@ collect_lpat (L _ pat) bndrs go (ViewPat _ pat _) = collect_lpat pat bndrs go (ParPat pat) = collect_lpat pat bndrs - go (ListPat pats _) = foldr collect_lpat bndrs pats + go (ListPat pats _ _) = foldr collect_lpat bndrs pats go (PArrPat pats _) = foldr collect_lpat bndrs pats go (TuplePat pats _ _) = foldr collect_lpat bndrs pats @@ -754,7 +754,7 @@ lPatImplicits = hs_lpat hs_pat (AsPat _ pat) = hs_lpat pat hs_pat (ViewPat _ pat _) = hs_lpat pat hs_pat (ParPat pat) = hs_lpat pat - hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (ListPat pats _ _) = hs_lpats pats hs_pat (PArrPat pats _) = hs_lpats pats hs_pat (TuplePat pats _ _) = hs_lpats pats diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 1748e94709..c47066d1b6 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -1051,7 +1051,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut_ty = exprType scrut' case_bndr' = mkLocalId case_bndr_name scrut_ty tc_app = splitTyConApp scrut_ty - -- NB: Won't always succeed (polymoprhic case) + -- NB: Won't always succeed (polymorphic case) -- but won't be demanded in those cases -- NB: not tcSplitTyConApp; we are looking at Core here -- look through non-rec newtypes to find the tycon that diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 047cc018da..817d789a93 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -145,12 +145,14 @@ outputAsm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' let filenmDyn = filenm ++ "-dyn" - withHandles f = doOutput filenm $ \h -> - ifGeneratingDynamicToo dflags - (doOutput filenmDyn $ \dynH -> - f [(h, dflags), - (dynH, doDynamicToo dflags)]) - (f [(h, dflags)]) + withHandles f = do debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + doOutput filenm $ \h -> + ifGeneratingDynamicToo dflags + (do debugTraceMsg dflags 4 (text "Outputing dynamic-too asm to" <+> text filenmDyn) + doOutput filenmDyn $ \dynH -> + f [(h, dflags), + (dynH, doDynamicToo dflags)]) + (f [(h, dflags)]) _ <- {-# SCC "OutputAsm" #-} withHandles $ \hs -> {-# SCC "NativeCodeGen" #-} diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 62ff424bb6..fa3b9dcad8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -482,6 +482,7 @@ data PipelineOutput -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. | SpecificFile FilePath -- ^ The output must go into the specified file. + deriving Show -- | Run a compilation pipeline, consisting of multiple phases. -- @@ -563,8 +564,9 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) SpecificFile fn -> SpecificFile (replaceExtension fn (objectSuf dflags')) Persistent -> Persistent Temporary -> Temporary + env' = env { output_spec = output' } hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase stop_phase hsc_env' env input_fn + _ <- runPipeline' start_phase stop_phase hsc_env' env' input_fn output' maybe_loc maybe_stub_o return () return r @@ -1023,8 +1025,11 @@ runPhase (Hsc src_flavour) input_fn dflags0 setStubO stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make - when (isHsBoot src_flavour) $ + when (isHsBoot src_flavour) $ do liftIO $ touchObjectFile dflags' o_file + whenGeneratingDynamicToo dflags' $ do + let dyn_o_file = addBootSuffix (replaceExtension o_file (dynObjectSuf dflags')) + liftIO $ touchObjectFile dflags' dyn_o_file return (next_phase, output_fn) ----------------------------------------------------------------------------- @@ -1275,8 +1280,15 @@ runPhase As input_fn dflags , SysTools.FileOption "" outputFilename ]) + liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") runAssembler input_fn output_fn - whenGeneratingDynamicToo dflags $ + -- If we're compiling a Haskell module (isHaskellishFile), and + -- we're doing -dynamic-too, then we also need to assemble the + -- -dyn assembly file. + env <- getPipeEnv + when (pe_isHaskellishFile env) $ whenGeneratingDynamicToo dflags $ do + liftIO $ debugTraceMsg dflags 4 + (text "Running the assembler again for -dynamic-too") runAssembler (input_fn ++ "-dyn") (replaceExtension output_fn (dynObjectSuf dflags)) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 9bfef011e2..3591a30d25 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -169,10 +169,13 @@ import qualified Data.Set as Set import Data.Word import System.FilePath import System.IO +import System.IO.Error import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet +import GHC.Foreign (withCString, peekCString) + -- ----------------------------------------------------------------------------- -- DynFlags @@ -480,6 +483,7 @@ data ExtensionFlag | Opt_BangPatterns | Opt_TypeFamilies | Opt_OverloadedStrings + | Opt_OverloadedLists | Opt_DisambiguateRecordFields | Opt_RecordWildCards | Opt_RecordPuns @@ -707,6 +711,8 @@ data DynFlags = DynFlags { pprCols :: Int, traceLevel :: Int, -- Standard level is 1. Less verbose is 0. + useUnicodeQuotes :: Bool, + -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, @@ -1175,6 +1181,12 @@ initDynFlags dflags = do refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 wrapperNum <- newIORef 0 + canUseUnicodeQuotes <- do let enc = localeEncoding + str = "‛’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False return dflags{ canGenerateDynamicToo = refCanGenerateDynamicToo, filesToClean = refFilesToClean, @@ -1182,7 +1194,8 @@ initDynFlags dflags = do filesToNotIntermediateClean = refFilesToNotIntermediateClean, generatedDumps = refGeneratedDumps, llvmVersion = refLlvmVersion, - nextWrapperNum = wrapperNum + nextWrapperNum = wrapperNum, + useUnicodeQuotes = canUseUnicodeQuotes } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -1307,6 +1320,7 @@ defaultDynFlags mySettings = flushErr = defaultFlushErr, pprUserLength = 5, pprCols = 100, + useUnicodeQuotes = False, traceLevel = 1, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion", @@ -2594,6 +2608,7 @@ xFlags = [ deprecatedForExtension "NamedFieldPuns" ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ), + ( "OverloadedLists", Opt_OverloadedLists, nop), ( "GADTs", Opt_GADTs, nop ), ( "GADTSyntax", Opt_GADTSyntax, nop ), ( "ViewPatterns", Opt_ViewPatterns, nop ), diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index da54e49e66..04ec5a4e7d 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -9,3 +9,4 @@ targetPlatform :: DynFlags -> Platform pprUserLength :: DynFlags -> Int pprCols :: DynFlags -> Int unsafeGlobalDynFlags :: DynFlags +useUnicodeQuotes :: DynFlags -> Bool diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ee40a1343d..483da4b5e4 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -17,7 +17,6 @@ module GHC ( runGhc, runGhcT, initGhcMonad, gcatch, gbracket, gfinally, printException, - printExceptionAndWarnings, handleSourceError, needsTemplateHaskell, diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 6b8c7bacdf..66034e0b50 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -18,7 +18,7 @@ module GhcMonad ( Session(..), withSession, modifySession, withTempSession, -- ** Warnings - logWarnings, printException, printExceptionAndWarnings, + logWarnings, printException, WarnErrLogger, defaultWarnErrLogger ) where @@ -110,8 +110,6 @@ instance MonadFix Ghc where instance ExceptionMonad Ghc where gcatch act handle = Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gblock (Ghc m) = Ghc $ \s -> gblock (m s) - gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) gmask f = Ghc $ \s -> gmask $ \io_restore -> let @@ -169,8 +167,6 @@ instance MonadIO m => MonadIO (GhcT m) where instance ExceptionMonad m => ExceptionMonad (GhcT m) where gcatch act handle = GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gblock (GhcT m) = GhcT $ \s -> gblock (m s) - gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) gmask f = GhcT $ \s -> gmask $ \io_restore -> let @@ -193,10 +189,6 @@ printException err = do dflags <- getSessionDynFlags liftIO $ printBagOfErrors dflags (srcErrorMessages err) -{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-} -printExceptionAndWarnings :: GhcMonad m => SourceError -> m () -printExceptionAndWarnings = printException - -- | A function called to log warnings and errors. type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 40a7a25ccd..79af4f6673 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -284,10 +284,11 @@ initSysTools mbMinusB ++ gcc_args -- Other things being equal, as and ld are simply gcc + gcc_link_args_str <- getSetting "C compiler link flags" let as_prog = gcc_prog as_args = gcc_args ld_prog = gcc_prog - ld_args = gcc_args + ld_args = gcc_args ++ map Option (words gcc_link_args_str) -- We just assume on command line lc_prog <- getSetting "LLVM llc command" diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index d49d43702b..72b887a588 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -459,18 +459,21 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars | (var, var_v) <- varEnvElts vars , let tidy_var = lookup_var var tidy_var_v = lookup_var var_v - , isExportedId tidy_var - , isExternalId tidy_var_v + , isExternalId tidy_var && isExportedId tidy_var + , isExternalId tidy_var_v && isExportedId tidy_var_v , isDataConWorkId var || not (isImplicitId var) ] tidy_parallelVars = mkVarSet [ tidy_var | var <- varSetElems parallelVars , let tidy_var = lookup_var var - , isExternalId tidy_var] + , isExternalId tidy_var && isExportedId tidy_var + ] lookup_var var = lookupWithDefaultVarEnv var_env var var + -- We need to make sure that all names getting into the iface version of 'VectInfo' are + -- external; otherwise, 'MkIface' will bomb out. isExternalId = isExternalName . idName \end{code} diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index c6cdd8a4d2..36aebea2c7 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1820,6 +1820,8 @@ genCCall32' :: DynFlags -> NatM InstrBlock genCCall32' dflags target dest_regs args = do let + prom_args = map (maybePromoteCArg dflags W32) args + -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] @@ -1831,7 +1833,7 @@ genCCall32' dflags target dest_regs args = do setDeltaNat (delta0 - arg_pad_size) use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse args) + push_codes <- mapM (push_arg use_sse2) (reverse prom_args) delta <- getDeltaNat MASSERT (delta == delta0 - tot_arg_size) @@ -2055,12 +2057,14 @@ genCCall64' :: DynFlags -> NatM InstrBlock genCCall64' dflags target dest_regs args = do -- load up the register arguments + let prom_args = map (maybePromoteCArg dflags W32) args + (stack_args, int_regs_used, fp_regs_used, load_args_code) <- if platformOS platform == OSMinGW32 - then load_args_win args [] [] (allArgRegs platform) nilOL + then load_args_win prom_args [] [] (allArgRegs platform) nilOL else do (stack_args, aregs, fregs, load_args_code) - <- load_args args (allIntArgRegs platform) (allFPArgRegs platform) nilOL + <- load_args prom_args (allIntArgRegs platform) (allFPArgRegs platform) nilOL let fp_regs_used = reverse (drop (length fregs) (reverse (allFPArgRegs platform))) int_regs_used = reverse (drop (length aregs) (reverse (allIntArgRegs platform))) return (stack_args, int_regs_used, fp_regs_used, load_args_code) @@ -2231,9 +2235,6 @@ genCCall64' dflags target dest_regs args = do push_args rest code' | otherwise = do - -- we only ever generate word-sized function arguments. Promotion - -- has already happened: our Int8# type is kept sign-extended - -- in an Int#, for example. ASSERT(width == W64) return () (arg_op, arg_code) <- getOperand arg delta <- getDeltaNat @@ -2253,6 +2254,13 @@ genCCall64' dflags target dest_regs args = do SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), DELTA (delta - n * arg_size)] +maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr +maybePromoteCArg dflags wto arg + | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg] + | otherwise = arg + where + wfrom = cmmExprWidth dflags arg + -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one -- used by GCC and LLVM. diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2746faa34e..fdf75cf003 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -339,7 +339,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } } <0> { - "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol } + "(#" / { ifExtension unboxedTuplesEnabled } { token IToubxparen } "#)" / { ifExtension unboxedTuplesEnabled } { token ITcubxparen } @@ -2389,8 +2389,11 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr Nothing -> lexError "unknown pragma" known_pragma :: Map String Action -> AlexAccPred Int -known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags) - && (nextCharIsNot buf (\c -> isAlphaNum c || c == '_')) +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' clean_pragma :: String -> String clean_pragma prag = canon_ws (map toLower (unprefix prag)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 72537a9a1b..18651b97c2 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1617,12 +1617,12 @@ tup_tail :: { [HsTupArg RdrName] } -- avoiding another shift/reduce-conflict. list :: { LHsExpr RdrName } - : texp { L1 $ ExplicitList placeHolderType [$1] } - | lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) } - | texp '..' { LL $ ArithSeq noPostTcExpr (From $1) } - | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } - | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } - | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } + : texp { L1 $ ExplicitList placeHolderType Nothing [$1] } + | lexps { L1 $ ExplicitList placeHolderType Nothing (reverse (unLoc $1)) } + | texp '..' { LL $ ArithSeq noPostTcExpr Nothing (From $1) } + | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) } + | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) } + | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> return (sL (comb2 $1 $>) $ diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index f7236b89c8..3695daef58 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -619,8 +619,8 @@ checkAPat msg loc e0 = do _ -> patFail msg loc e0 HsPar e -> checkLPat msg e >>= (return . ParPat) - ExplicitList _ es -> do ps <- mapM (checkLPat msg) es - return (ListPat ps placeHolderType) + ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es + return (ListPat ps placeHolderType Nothing) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es return (PArrPat ps placeHolderType) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index a67580a18c..19acf488e0 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -227,13 +227,19 @@ basicKnownKeyNames -- Stable pointers newStablePtrName, - -- GHC Extensions + -- GHC Extensions groupWithName, -- Strings and lists unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, @@ -570,6 +576,11 @@ plus_RDR = varQual_RDR gHC_NUM (fsLit "+") fromString_RDR :: RdrName fromString_RDR = nameRdrName fromStringName +fromList_RDR, fromListN_RDR, toList_RDR :: RdrName +fromList_RDR = nameRdrName fromListName +fromListN_RDR = nameRdrName fromListNName +toList_RDR = nameRdrName toListName + compose_RDR :: RdrName compose_RDR = varQual_RDR gHC_BASE (fsLit ".") @@ -1002,6 +1013,13 @@ concatName = varQual gHC_LIST (fsLit "concat") concatIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey zipName = varQual gHC_LIST (fsLit "zip") zipIdKey +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = methName gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = methName gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = methName gHC_EXTS (fsLit "toList") toListClassOpKey + -- Class Show showClassName :: Name showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey @@ -1743,6 +1761,12 @@ mzipIdKey = mkPreludeMiscIdUnique 196 ghciStepIoMClassOpKey :: Unique ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 diff --git a/compiler/prelude/PrelNames.lhs-boot b/compiler/prelude/PrelNames.lhs-boot index c14695b060..7b5365e621 100644 --- a/compiler/prelude/PrelNames.lhs-boot +++ b/compiler/prelude/PrelNames.lhs-boot @@ -1,9 +1,10 @@ - \begin{code} module PrelNames where import Module +import Unique mAIN :: Module +liftedTypeKindTyConKey :: Unique \end{code} diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 2e55e497d7..079ab0cc98 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -100,6 +100,15 @@ primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intO retLit zeroi , equalArgs >> retLit zeroi , equalArgs >> retLit zeroi ] +primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] +primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityDynFlags zeroi ] +primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityDynFlags zeroi + , equalArgs >> retLit zeroi ] primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp IntNegOp ] primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL) diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index e83fcb5255..8ee2d3f53e 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -48,7 +48,7 @@ module TysWiredIn ( wordTyCon, wordDataCon, wordTyConName, wordTy, -- * List - listTyCon, nilDataCon, consDataCon, consDataConName, + listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName, listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, mkPromotedListTy, diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index a5b0fec908..45472816c0 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -217,6 +217,17 @@ primop IntQuotRemOp "quotRemInt#" GenPrimOp {Rounds towards zero.} with can_fail = True +primop AndIOp "andI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop OrIOp "orI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop XorIOp "xorI#" Dyadic Int# -> Int# -> Int# + with commutable = True + +primop NotIOp "notI#" Monadic Int# -> Int# + primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 038e775fe9..90061b10a2 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -11,6 +11,7 @@ module RnEnv ( lookupLocalOccRn_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, + reportUnboundName, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, @@ -543,9 +544,11 @@ lookupLocalOccRn_maybe rdr_name -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name -lookupOccRn rdr_name = do - opt_name <- lookupOccRn_maybe rdr_name - maybe (unboundName WL_Any rdr_name) return opt_name +lookupOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> reportUnboundName rdr_name } lookupKindOccRn :: RdrName -> RnM Name -- Looking up a name occurring in a kind @@ -553,7 +556,7 @@ lookupKindOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of Just name -> return name - Nothing -> unboundName WL_Any rdr_name } + Nothing -> reportUnboundName rdr_name } -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name @@ -571,13 +574,13 @@ lookup_demoted rdr_name = do { data_kinds <- xoptM Opt_DataKinds ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of - Nothing -> unboundName WL_Any rdr_name + Nothing -> reportUnboundName rdr_name Just demoted_name | data_kinds -> return demoted_name | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } | otherwise - = unboundName WL_Any rdr_name + = reportUnboundName rdr_name where suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") @@ -1354,6 +1357,9 @@ data WhereLooking = WL_Any -- Any binding | WL_Global -- Any top-level binding (local or imported) | WL_LocalTop -- Any top-level binding in this module +reportUnboundName :: RdrName -> RnM Name +reportUnboundName rdr = unboundName WL_Any rdr + unboundName :: WhereLooking -> RdrName -> RnM Name unboundName wl rdr = unboundNameX wl rdr empty diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 8e4d554a46..29674ca34c 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -53,6 +53,7 @@ import Outputable import SrcLoc import FastString import Control.Monad +import TysWiredIn ( nilDataConName ) \end{code} @@ -108,14 +109,18 @@ finishHsVar name ; return (e, unitFV name) } } rnExpr (HsVar v) - = do { opt_TypeHoles <- xoptM Opt_TypeHoles - ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) - then do { mb_name <- lookupOccRn_maybe v - ; case mb_name of - Nothing -> return (HsUnboundVar v, emptyFVs) - Just n -> finishHsVar n } - else do { name <- lookupOccRn v - ; finishHsVar name } } + = do { mb_name <- lookupOccRn_maybe v + ; case mb_name of { + Nothing -> do { opt_TypeHoles <- xoptM Opt_TypeHoles + ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) + then return (HsUnboundVar v, emptyFVs) + else do { n <- reportUnboundName v; finishHsVar n } } ; + Just name + | name == nilDataConName -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -> rnExpr (ExplicitList placeHolderType Nothing []) + | otherwise + -> finishHsVar name } } rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) @@ -249,9 +254,15 @@ rnExpr (HsDo do_or_lc stmts _) = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } -rnExpr (ExplicitList _ exps) - = rnExprs exps `thenM` \ (exps', fvs) -> - return (ExplicitList placeHolderType exps', fvs) +rnExpr (ExplicitList _ _ exps) + = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists + ; (exps', fvs) <- rnExprs exps + ; if opt_OverloadedLists + then do { + ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } + else + return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@ -299,9 +310,15 @@ rnExpr (HsType a) = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) -rnExpr (ArithSeq _ seq) - = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - return (ArithSeq noPostTcExpr new_seq, fvs) +rnExpr (ArithSeq _ _ seq) + = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists + ; (new_seq, fvs) <- rnArithSeq seq + ; if opt_OverloadedLists + then do { + ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + else + return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 9738585aa4..a039f36b25 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -61,6 +61,8 @@ import SrcLoc import FastString import Literal ( inCharRange ) import Control.Monad ( when ) +import TysWiredIn ( nilDataCon ) +import DataCon ( dataConName ) \end{code} @@ -375,11 +377,20 @@ rnPatAndThen mk p@(ViewPat expr pat ty) rnPatAndThen mk (ConPatIn con stuff) -- rnConPatAndThen takes care of reconstructing the pattern - = rnConPatAndThen mk con stuff - -rnPatAndThen mk (ListPat pats _) - = do { pats' <- rnLPatsAndThen mk pats - ; return (ListPat pats' placeHolderType) } + -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. + = case unLoc con == nameRdrName (dataConName nilDataCon) of + True -> do { ol_flag <- liftCps $ xoptM Opt_OverloadedLists + ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) + else rnConPatAndThen mk con stuff} + False -> rnConPatAndThen mk con stuff + +rnPatAndThen mk (ListPat pats _ _) + = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists + ; pats' <- rnLPatsAndThen mk pats + ; case opt_OverloadedLists of + True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))} + False -> return (ListPat pats' placeHolderType Nothing) } rnPatAndThen mk (PArrPat pats _) = do { pats' <- rnLPatsAndThen mk pats diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 7ff473f8c7..cc410388df 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -44,6 +44,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad import Data.List( partition ) +import Data.Traversable (traverse) import Maybes( orElse ) \end{code} @@ -339,7 +340,7 @@ rnAnnDecl (HsAnnotation provenance expr) = do rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) rnAnnProvenance provenance = do - provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance + provenance' <- traverse lookupTopBndrRn provenance return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) \end{code} diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 6e01f9647a..62a546de96 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -621,6 +621,12 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) vectVars = mkVarSet $ catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr | Vect bndr _ <- mg_vect_decls guts] + ++ + catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr + | bndr <- bindersOfBinds binds] + -- FIXME: This second comprehensions is only needed as long as we + -- have vectorised bindings where we get "Could NOT call + -- vectorised from original version". ; (maybeVects, maybeVectVars) = case sm_phase mode of InitialPhase -> (mg_vect_decls guts, vectVars) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7374e62d1a..6a83268759 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -379,7 +379,7 @@ tcDeriving tycl_decls inst_decls deriv_decls deriveTypeable tys = [ L l (DerivDecl (L l (HsAppTy (noLoc (HsTyVar typeableClassName)) (L l (HsTyVar (tcdName t)))))) - | L l t <- tys ] + | L l t <- tys, not (isSynDecl t), not (isTypeFamilyDecl t) ] -- Prints the representable type family instance pprRepTy :: FamInst Unbranched -> SDoc diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 273301314a..7766dd721d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -15,8 +15,8 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, tcCheckId, - addExprErrCtxt ) where - + addExprErrCtxt) where + #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ @@ -401,12 +401,18 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } -tcExpr (ExplicitList _ exprs) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') } - where - tc_elt elt_ty expr = tcPolyExpr expr elt_ty +tcExpr (ExplicitList _ witness exprs) res_ty + = case witness of + Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') } + + Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind + ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty) + ; (coi, elt_ty) <- matchExpectedListTy list_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') } + where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty @@ -757,40 +763,8 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty %************************************************************************ \begin{code} -tcExpr (ArithSeq _ seq@(From expr)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName elt_ty - ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) } - -tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName elt_ty - ; return $ mkHsWrapCo coi - (ArithSeq enum_from_then (FromThen expr1' expr2')) } - -tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName elt_ty - ; return $ mkHsWrapCo coi - (ArithSeq enum_from_to (FromTo expr1' expr2')) } - -tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName elt_ty - ; return $ mkHsWrapCo coi - (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty @@ -851,6 +825,61 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) %************************************************************************ %* * + Arithmetic sequences [a..b] etc +%* * +%************************************************************************ + +\begin{code} +tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType + -> TcM (HsExpr TcId) + +tcArithSeq witness seq@(From expr) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <- tcPolyExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; expr3' <- tcPolyExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName elt_ty + ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType + -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id)) +arithSeqEltType Nothing res_ty + = do { (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (coi, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { list_ty <- newFlexiTyVarTy liftedTypeKind + ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty) + ; (coi, elt_ty) <- matchExpectedListTy list_ty + ; return (coi, elt_ty, Just fl') } +\end{code} + +%************************************************************************ +%* * Applications %* * %************************************************************************ diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 0f6a879b52..1e2961258d 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -97,7 +97,8 @@ hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit hsPatType (AsPat var _) = idType (unLoc var) hsPatType (ViewPat _ _ ty) = ty -hsPatType (ListPat _ ty) = mkListTy ty +hsPatType (ListPat _ ty Nothing) = mkListTy ty +hsPatType (ListPat _ _ (Just (ty,_))) = ty hsPatType (PArrPat _ ty) = mkPArrTy ty hsPatType (TuplePat _ _ ty) = ty hsPatType (ConPatOut { pat_ty = ty }) = ty @@ -411,7 +412,7 @@ localSigWarnId sig_ns id | idName id `elemNameSet` sig_ns = return () | otherwise = warnMissingSig msg id where - msg = ptext (sLit "Polymophic local binding with no type signature:") + msg = ptext (sLit "Polymorphic local binding with no type signature:") warnMissingSig :: SDoc -> Id -> TcM () warnMissingSig msg id @@ -647,10 +648,14 @@ zonkExpr env (HsDo do_or_lc stmts ty) zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsDo do_or_lc new_stmts new_ty) -zonkExpr env (ExplicitList ty exprs) +zonkExpr env (ExplicitList ty wit exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> + zonkWit env wit `thenM` \ new_wit -> zonkLExprs env exprs `thenM` \ new_exprs -> - returnM (ExplicitList new_ty new_exprs) + returnM (ExplicitList new_ty new_wit new_exprs) + where zonkWit _ Nothing = returnM Nothing + zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln -> + returnM (Just new_fln) zonkExpr env (ExplicitPArr ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -675,10 +680,14 @@ zonkExpr env (ExprWithTySigOut e ty) zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" -zonkExpr env (ArithSeq expr info) +zonkExpr env (ArithSeq expr wit info) = zonkExpr env expr `thenM` \ new_expr -> + zonkWit env wit `thenM` \ new_wit -> zonkArithSeq env info `thenM` \ new_info -> - returnM (ArithSeq new_expr new_info) + returnM (ArithSeq new_expr new_wit new_info) + where zonkWit _ Nothing = returnM Nothing + zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln -> + returnM (Just new_fln) zonkExpr env (PArrSeq expr info) = zonkExpr env expr `thenM` \ new_expr -> @@ -991,10 +1000,17 @@ zonk_pat env (ViewPat expr pat ty) ; ty' <- zonkTcTypeToType env ty ; return (env', ViewPat expr' pat' ty') } -zonk_pat env (ListPat pats ty) +zonk_pat env (ListPat pats ty Nothing) = do { ty' <- zonkTcTypeToType env ty ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty') } + ; return (env', ListPat pats' ty' Nothing) } + +zonk_pat env (ListPat pats ty (Just (ty2,wit))) + = do { wit' <- zonkExpr env wit + ; ty2' <- zonkTcTypeToType env ty2 + ; ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty' (Just (ty2',wit'))) } zonk_pat env (PArrPat pats ty) = do { ty' <- zonkTcTypeToType env ty diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 9775ea77b0..cde55a65fd 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -181,7 +181,7 @@ tcHsSigTypeNC ctxt (L loc hs_ty) -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] - -- Generalise here: see Note [ generalisation] + -- Generalise here: see Note [Kind generalisation] ; ty <- tcCheckHsTypeAndGen hs_ty kind -- Zonk to expose kind information to checkValidType diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 2889c53e82..f4759659d6 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -30,6 +30,7 @@ import Id import Var import Name import TcEnv +--import TcExpr import TcMType import TcValidity( arityErr ) import TcType @@ -282,7 +283,7 @@ mkLocalBinder name ty Note [Polymorphism and pattern bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When is_mono holds we are not generalising -But the signature can still be polymoprhic! +But the signature can still be polymorphic! data T = MkT (forall a. a->a) x :: forall a. a->a MkT x = <rhs> @@ -451,11 +452,20 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside ------------------------ -- Lists, tuples, arrays -tc_pat penv (ListPat pats _) pat_ty thing_inside - = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty +tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside + = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) pats penv thing_inside - ; return (mkHsWrapPat coi (ListPat pats' elt_ty) pat_ty, res) + ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) + } + +tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside + = do { list_pat_ty <- newFlexiTyVarTy liftedTypeKind + ; e' <- tcSyntaxOp ListOrigin e (mkFunTy pat_ty list_pat_ty) + ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy list_pat_ty + ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty) + pats penv thing_inside + ; return (mkHsWrapPat coi (ListPat pats' elt_ty (Just (pat_ty,e'))) list_pat_ty, res) } tc_pat penv (PArrPat pats _) pat_ty thing_inside diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index c103385e4e..5b7eb739b4 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1475,7 +1475,7 @@ tcGhciStmts stmts -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ; mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) (nlHsVar id) ; stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] @@ -1575,27 +1575,42 @@ tcRnType :: HscEnv -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env ictxt normalise rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env ictxt $ do { - - (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ; - failIfErrsM ; + setInteractiveContext hsc_env ictxt $ + setXOptM Opt_PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type + ; failIfErrsM -- Now kind-check the type -- It can have any rank or kind - ty <- tcHsSigType GhciCtxt rn_type ; + ; ty <- tcHsSigType GhciCtxt rn_type ; - ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs - ; return (snd (normaliseType fam_envs ty)) } - -- normaliseType returns a coercion - -- which we discard - else return ty ; - - return (ty', typeKind ty) - } + ; ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs + ; return (snd (normaliseType fam_envs ty)) } + -- normaliseType returns a coercion + -- which we discard + else return ty ; + ; return (ty', typeKind ty) } \end{code} +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type. This gives the right default behaviour at +the GHCi prompt, where if you say ":k T", and T has a polymorphic +kind, you'd like to see that polymorphism. Of course. If T isn't +kind-polymorphic you won't get anything unexpected, but the apparent +*loss* of polymorphism, for types that you know are polymorphic, is +quite surprising. See Trac #7688 for a discussion. + + +%************************************************************************ +%* * + tcRnDeclsi +%* * +%************************************************************************ + tcRnDeclsi exists to allow class, data, and other declarations in GHCi. \begin{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 0b28f4db80..e70f67422d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -1543,7 +1543,8 @@ data CtOrigin | FunDepOrigin | HoleOrigin | UnboundOccurrenceOf RdrName - + | ListOrigin -- An overloaded list + pprO :: CtOrigin -> SDoc pprO (GivenOrigin sk) = ppr sk pprO (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)] @@ -1580,6 +1581,7 @@ pprO AnnOrigin = ptext (sLit "an annotation") pprO FunDepOrigin = ptext (sLit "a functional dependency") pprO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") pprO (UnboundOccurrenceOf name) = hsep [ptext (sLit "an undeclared identifier"), quotes (ppr name)] +pprO ListOrigin = ptext (sLit "an overloaded list") instance Outputable CtOrigin where ppr = pprO diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index e0af05bdad..b21888a76d 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -266,6 +266,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds meta_tvs = filter isMetaTyVar (varSetElems (tyVarsOfCts quant_cand)) ; ((flats, _insols), _extra_binds) <- runTcS $ do { mapM_ (promoteAndDefaultTyVar untch gbl_tvs) meta_tvs + -- See Note [Promote _and_ default when inferring] ; _implics <- solveInteract quant_cand ; getInertUnsolved } ; return (map ctPred $ filter isWantedCt (bagToList flats)) } @@ -910,6 +911,7 @@ have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it should! If we don't solve the constraint, we'll stupidly quantify over (C (a->Int)) and, worse, in doing so zonkQuantifiedTyVar will quantify over (b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. +Trac #7641 is a simpler example. Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 1add302eb0..679d39cb7c 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -419,14 +419,18 @@ splitAppTys ty = split ty ty [] mkNumLitTy :: Integer -> Type mkNumLitTy n = LitTy (NumTyLit n) +-- | Is this a numeric literal. We also look through type synonyms. isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty | Just ty1 <- tcView ty = isNumLitTy ty1 isNumLitTy (LitTy (NumTyLit n)) = Just n isNumLitTy _ = Nothing mkStrLitTy :: FastString -> Type mkStrLitTy s = LitTy (StrTyLit s) +-- | Is this a symbol literal. We also look through type synonyms. isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty | Just ty1 <- tcView ty = isStrLitTy ty1 isStrLitTy (LitTy (StrTyLit s)) = Just s isStrLitTy _ = Nothing diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index b748b8943d..f7fdd595aa 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -666,17 +666,9 @@ See Trac #2766. \begin{code} pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc -pprTcApp _ _ tc [] -- No brackets for SymOcc - = pp_nt_debug <> ppr tc - where - pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc - then ptext (sLit "<recnt>") - else ptext (sLit "<nt>")) - | otherwise = empty - pprTcApp _ pp tc [ty] - | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys @@ -701,27 +693,35 @@ pprTcApp p pp tc tys = pprInfixApp p pp (ppr tc) ty1 ty2 | otherwise - = ppr_type_name_app p pp (ppr tc) (isSymOcc (getOccName tc)) tys + = ppr_type_name_app p pp (getName tc) (ppr tc) tys ---------------- -pprTypeApp :: NamedThing a => a -> [Type] -> SDoc --- The first arg is the tycon, or sometimes class --- Print infix if the tycon/class looks like an operator +pprTypeApp :: TyCon -> [Type] -> SDoc pprTypeApp tc tys - = pprTypeNameApp TopPrec ppr_type (getName tc) tys + = ppr_type_name_app TopPrec ppr_type (getName tc) (ppr tc) tys + -- We have to to use ppr on the TyCon (not its name) + -- so that we get promotion quotes in the right place pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc -- Used for classes and coercions as well as types; that's why it's separate from pprTcApp pprTypeNameApp p pp name tys - = ppr_type_name_app p pp (ppr name) (isSymOcc (getOccName name)) tys + = ppr_type_name_app p pp name (ppr name) tys + +ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> Name -> SDoc -> [a] -> SDoc +ppr_type_name_app p pp nm_tc pp_tc tys + | not (isSymOcc (nameOccName nm_tc)) + = pprPrefixApp p pp_tc (map (pp TyConPrec) tys) -ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> SDoc -> Bool -> [a] -> SDoc -ppr_type_name_app p pp pp_tc is_sym_occ tys - | is_sym_occ -- Print infix if possible - , [ty1,ty2] <- tys -- We know nothing of precedence though + | [ty1,ty2] <- tys -- Infix, two arguments; + -- we know nothing of precedence though = pprInfixApp p pp pp_tc ty1 ty2 + + | nm_tc `hasKey` liftedTypeKindTyConKey + || nm_tc `hasKey` unliftedTypeKindTyConKey + = ASSERT( null tys ) pp_tc -- Do not wrap *, # in parens + | otherwise - = pprPrefixApp p (pprPrefixVar is_sym_occ pp_tc) (map (pp TyConPrec) tys) + = pprPrefixApp p (parens pp_tc) (map (pp TyConPrec) tys) ---------------- pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs index b4908997a8..850393e359 100644 --- a/compiler/utils/Exception.hs +++ b/compiler/utils/Exception.hs @@ -21,11 +21,11 @@ tryIO = try -- | A monad that can catch exceptions. A minimal definition -- requires a definition of 'gcatch'. -- --- Implementations on top of 'IO' should implement 'gblock' and 'gunblock' to --- eventually call the primitives 'Control.Exception.block' and --- 'Control.Exception.unblock' respectively. These are used for +-- Implementations on top of 'IO' should implement 'gmask' to +-- eventually call the primitive 'Control.Exception.mask'. +-- These are used for -- implementations that support asynchronous exceptions. The default --- implementations of 'gbracket' and 'gfinally' use 'gblock' and 'gunblock' +-- implementations of 'gbracket' and 'gfinally' use 'gmask' -- thus rarely require overriding. -- class MonadIO m => ExceptionMonad m where @@ -46,20 +46,6 @@ class MonadIO m => ExceptionMonad m where -- exception handling monad instead of just 'IO'. gfinally :: m a -> m b -> m a - -- | DEPRECATED, here for backwards compatibilty. Instances can - -- define either 'gmask', or both 'block' and 'unblock'. - gblock :: m a -> m a - -- | DEPRECATED, here for backwards compatibilty Instances can - -- define either 'gmask', or both 'block' and 'unblock'. - gunblock :: m a -> m a - -- XXX we're keeping these two methods for the time being because we - -- have to interact with Haskeline's MonadException class which - -- still has block/unblock; see GhciMonad.hs. - - gmask f = gblock (f gunblock) - gblock f = gmask (\_ -> f) - gunblock f = f -- XXX wrong; better override this if you need it - gbracket before after thing = gmask $ \restore -> do a <- before @@ -76,8 +62,6 @@ class MonadIO m => ExceptionMonad m where instance ExceptionMonad IO where gcatch = Control.Exception.catch gmask f = mask (\x -> f x) - gblock = block - gunblock = unblock gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) gtry act = gcatch (act >>= \a -> return (Right a)) diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 4e741b44fb..f26f918068 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -72,6 +72,7 @@ module Outputable ( import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, + useUnicodeQuotes, unsafeGlobalDynFlags ) import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} Name( Name, nameModule ) @@ -260,7 +261,9 @@ pprDeeper d = SDoc $ \ctx -> case ctx of pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth -pprDeeperList f ds = SDoc work +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work where work ctx@SDC{sdocStyle=PprUser q (PartWay n)} | n==0 = Pretty.text "..." @@ -446,7 +449,11 @@ cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- 'quotes' encloses something in single quotes... -- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. -quotes d = SDoc $ \sty -> +quotes d = + sdocWithDynFlags $ \dflags -> + if useUnicodeQuotes dflags + then char '‛' <> d <> char '’' + else SDoc $ \sty -> let pp_d = runSDoc d sty str = show pp_d in case (str, snocView str) of diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 706fc85166..fb0c148610 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -1211,12 +1211,17 @@ maybeParrTy ty maybeParrTy (ForAllTy _ ty) = maybeParrTy ty maybeParrTy _ = return False --- Are the types of all variables in the 'Scalar' class? +-- Are the types of all variables in the 'Scalar' class or toplevel variables? +-- +-- NB: 'liftSimple' does not abstract over toplevel variables. -- allScalarVarType :: [Var] -> VM Bool -allScalarVarType vs = and <$> mapM (isScalar . varType) vs +allScalarVarType vs = and <$> mapM isScalarOrToplevel vs + where + isScalarOrToplevel v | isToplevel v = return True + | otherwise = isScalar (varType v) --- Are the types of all variables in the set in the 'Scalar' class? +-- Are the types of all variables in the set in the 'Scalar' class or toplevel variables? -- allScalarVarTypeSet :: VarSet -> VM Bool allScalarVarTypeSet = allScalarVarType . varSetElems |