diff options
Diffstat (limited to 'ghc/compiler/deSugar')
| -rw-r--r-- | ghc/compiler/deSugar/Desugar.lhs | 59 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsBinds.lhs | 123 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsExpr.lhs | 144 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsGRHSs.lhs | 6 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsHsSyn.lhs | 1 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsListComp.lhs | 150 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsLoop.lhi | 2 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsMonad.lhs | 51 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/DsUtils.lhs | 19 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/Match.lhs | 74 | ||||
| -rw-r--r-- | ghc/compiler/deSugar/MatchLit.lhs | 70 |
11 files changed, 393 insertions, 306 deletions
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 697c32dd2f..40e3bcc1fc 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -6,23 +6,28 @@ \begin{code} #include "HsVersions.h" -module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where +module Desugar ( deSugar, DsMatchContext, pprDsWarnings, + DsWarnFlavour -- removed when compiling with 1.4 + ) where IMP_Ubiq(){-uitous-} import HsSyn ( HsBinds, HsExpr ) import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) import CoreSyn - +import Name ( isExported ) import DsMonad import DsBinds ( dsBinds, dsInstBinds ) import DsUtils import Bag ( unionBags ) -import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) +import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, opt_SccGroup + ) +import CostCentre ( IsCafCC(..), mkAutoCC ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) -import Id ( nullIdEnv, mkIdEnv ) +import Id ( nullIdEnv, mkIdEnv, idType, SYN_IE(DictVar), GenId ) import PprStyle ( PprStyle(..) ) import UniqSupply ( splitUniqSupply ) \end{code} @@ -42,7 +47,7 @@ deSugar :: UniqSupply -- name supply -- ToDo: handling of const_inst thingies is certainly WRONG *************************** -> ([CoreBinding], -- output - Bag DsMatchContext) -- Shadowing complaints + DsWarnings) -- Shadowing complaints deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_pairs) = let @@ -52,9 +57,11 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst (us3, us3a) = splitUniqSupply us2a (us4, us5) = splitUniqSupply us3a - auto_meth = opt_AutoSccsOnAllToplevs - auto_top = opt_AutoSccsOnAllToplevs - || opt_AutoSccsOnExportedToplevs + + module_and_group = (mod_name, grp_name) + grp_name = case opt_SccGroup of + Just xx -> _PK_ xx + Nothing -> mod_name -- default: module name ((core_const_prs, consts_pairs), shadows1) = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) @@ -62,19 +69,19 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst consts_env = mkIdEnv consts_pairs (core_clas_binds, shadows2) - = initDs us1 consts_env mod_name (dsBinds False clas_binds) + = initDs us1 consts_env mod_name (dsBinds clas_binds) core_clas_prs = pairsFromCoreBinds core_clas_binds (core_inst_binds, shadows3) - = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds) + = initDs us2 consts_env mod_name (dsBinds inst_binds) core_inst_prs = pairsFromCoreBinds core_inst_binds (core_val_binds, shadows4) - = initDs us3 consts_env mod_name (dsBinds auto_top val_binds) - core_val_pairs = pairsFromCoreBinds core_val_binds + = initDs us3 consts_env mod_name (dsBinds val_binds) + core_val_pairs = map (addAutoScc module_and_group) (pairsFromCoreBinds core_val_binds) (core_recsel_binds, shadows5) - = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds) + = initDs us4 consts_env mod_name (dsBinds recsel_binds) core_recsel_prs = pairsFromCoreBinds core_recsel_binds final_binds @@ -98,3 +105,29 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst in (really_final_binds, shadows) \end{code} + + +%************************************************************************ +%* * +\subsection[addAutoScc]{Adding automatic sccs} +%* * +%************************************************************************ + +\begin{code} +addAutoScc :: (FAST_STRING, FAST_STRING) -- Module and group + -> (Id, CoreExpr) + -> (Id,CoreExpr) + +addAutoScc (mod, grp) pair@(bndr, core_expr) + | worthSCC core_expr && + (opt_AutoSccsOnAllToplevs || + (isExported bndr && opt_AutoSccsOnExportedToplevs)) + = (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr) + + | otherwise + = pair + +worthSCC (SCC _ _) = False +worthSCC (Con _ _) = False +worthSCC core_expr = True +\end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 657e2652f1..af09307aba 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -29,7 +29,8 @@ import DsGRHSs ( dsGuarded ) import DsUtils import Match ( matchWrapper ) -import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_CompilingGhcInternals ) +import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, opt_CompilingGhcInternals ) import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre ) import Id ( idType, SYN_IE(DictVar), GenId ) import ListSetOps ( minusList, intersectLists ) @@ -59,7 +60,7 @@ that some of the binders are of unboxed type. This is sorted out when the caller wraps the bindings round an expression. \begin{code} -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] \end{code} All ``real'' bindings are expressed in terms of the @@ -95,12 +96,12 @@ But there are lots of special cases. %============================================== \begin{code} -dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith" -dsBinds auto_scc EmptyBinds = returnDs [] -dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind +dsBinds (BindWith _ _) = panic "dsBinds:BindWith" +dsBinds EmptyBinds = returnDs [] +dsBinds (SingleBind bind) = dsBind [] [] id [] bind -dsBinds auto_scc (ThenBinds binds_1 binds_2) - = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) +dsBinds (ThenBinds binds_1 binds_2) + = andDs (++) (dsBinds binds_1) (dsBinds binds_2) \end{code} @@ -129,7 +130,7 @@ definitions, which don't mention the type variables at all, so making them polymorphic is really overkill. @dsInstBinds@ deals with this case. \begin{code} -dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) +dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) = mapDs mk_poly_private_binder private_binders `thenDs` \ poly_private_binders -> let @@ -148,7 +149,7 @@ dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) -> extendEnvDs inst_env ( - dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds + dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds )) where -- "private_binders" is the list of binders in val_binds @@ -194,7 +195,7 @@ the defn of f' can get floated out, notably if f gets specialised to a particular type for a. \begin{code} -dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) +dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) = -- If there is any non-overloaded polymorphism, make new locals with -- appropriate polymorphism (if null non_overloaded_tyvars @@ -230,7 +231,7 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind extendEnvDs inst_env ( - dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds + dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds )) `thenDs` \ core_binds -> let @@ -240,7 +241,7 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind in mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs -> - returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ] + returnDs (mk_result_bind core_bind_prs) where locals = [local | (local,global) <- local_global_prs] non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars @@ -250,6 +251,14 @@ dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_bind binders = collectTypedBinders val_binds mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id)) + + is_rec_bind = case val_binds of + RecBind _ -> True + NonRecBind _ -> False + + -- Recursion can still be needed if there are type signatures + mk_result_bind prs | is_rec_bind = [Rec prs] + | otherwise = [NonRec binder rhs | (binder,rhs) <- prs] \end{code} @mkSatTyApp id tys@ constructs an expression whose value is (id tys). @@ -385,22 +394,21 @@ some of the binders are of unboxed type. For an explanation of the first three args, see @dsMonoBinds@. \begin{code} -dsBind :: Bool -- Add auto sccs to binds - -> [TyVar] -> [DictVar] -- Abstract wrt these +dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> [(Id,CoreExpr)] -- Inst bindings already dealt with -> TypecheckedBind -> DsM [CoreBinding] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind +dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) - = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> +dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) + = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] -dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) - = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> +dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) + = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] \end{code} @@ -424,8 +432,7 @@ of these binders into applications of the new binder to suitable type variables and dictionaries. \begin{code} -dsMonoBinds :: Bool -- True <=> add auto sccs - -> Bool -- True <=> recursive binding group +dsMonoBinds :: Bool -- True <=> recursive binding group -> [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> TypecheckedMonoBinds @@ -439,11 +446,11 @@ dsMonoBinds :: Bool -- True <=> add auto sccs %============================================== \begin{code} -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] +dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1) - (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2) +dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1) + (dsMonoBinds is_rec tyvars dicts binder_subst binds_2) \end{code} @@ -452,31 +459,27 @@ dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 bin %============================================== \begin{code} -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) - = doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] +dsMonoBinds is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr) + = returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr) +dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) = dsExpr expr `thenDs` \ core_expr -> - doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] + returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) +dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ let new_fun = binder_subst fun error_string = "function " ++ showForErr fun in matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> - doSccAuto auto_scc [fun] body `thenDs` \ sccd_body -> returnDs [(new_fun, - mkLam tyvars (dicts ++ args) sccd_body)] + mkLam tyvars (dicts ++ args) body)] -dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) +dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr -> - returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)] + returnDs [(binder_subst v, mkLam tyvars dicts body_expr)] \end{code} %============================================== @@ -490,7 +493,7 @@ be empty. (Simple pattern bindings were handled above.) First, the paranoia check. \begin{code} -dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) = panic "Non-empty dict list in for pattern binding" \end{code} @@ -518,11 +521,10 @@ Then we transform to: \end{description} \begin{code} -dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr -> {- KILLED by Sansom. 95/05 -- make *sure* there are no primitive types in the pattern @@ -535,11 +537,11 @@ dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_bi -- we can just use the rhs directly else -} --- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $ +-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] - sccd_body_expr + body_expr where pat_binders = collectTypedPatBinders pat -- NB For a simple tuple pattern, these binders @@ -552,40 +554,3 @@ extra work to benefit only rather unusual constructs like let (_,a,b) = ... in ... \end{verbatim} Better to extend the whole thing for any irrefutable constructor, at least. - -%************************************************************************ -%* * -\subsection[doSccAuto]{Adding automatic sccs} -%* * -%************************************************************************ - -\begin{code} -doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr - -doSccAuto False binders core_expr - = returnDs core_expr - -doSccAuto True [] core_expr -- no binders - = returnDs core_expr - -doSccAuto True _ core_expr@(SCC _ _) -- already sccd - = returnDs core_expr - -doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con - = returnDs core_expr - -doSccAuto True binders core_expr - = let - scc_all = opt_AutoSccsOnAllToplevs - scc_export = not (null export_binders) - - export_binders = filter isExported binders - - scc_binder = head (if scc_all then binders else export_binders) - in - if scc_all || scc_export then - getModuleAndGroupDs `thenDs` \ (mod,grp) -> - returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr) - else - returnDs core_expr -\end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 2efca382c9..96e870e4e8 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), Match(..), Qualifier, HsBinds, HsType, Fixity, + Stmt(..), DoOrListComp(..), Match(..), HsBinds, HsType, Fixity, GRHSsAndBinds ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), @@ -47,16 +47,17 @@ import PprType ( GenType ) import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId ) import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) import TyCon ( isDataTyCon, isNewTyCon ) -import Type ( splitSigmaTy, splitFunTy, typePrimRep, - getAppDataTyConExpandingDicts, getAppTyCon, applyTy, - maybeBoxedPrimType +import Type ( splitSigmaTy, splitFunTy, typePrimRep, + getAppDataTyConExpandingDicts, maybeAppTyCon, getAppTyCon, applyTy, + maybeBoxedPrimType, splitAppTy ) import TysPrim ( voidTy ) -import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, +import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon, listTyCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) import Usage ( SYN_IE(UVar) ) +import Maybes ( maybeToBool ) import Util ( zipEqual, pprError, panic, assertPanic ) mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... @@ -75,7 +76,7 @@ around; if we get hits, we use the value accordingly. \begin{code} dsExpr :: TypecheckedHsExpr -> DsM CoreExpr -dsExpr e@(HsVar var) = dsApp e [] +dsExpr e@(HsVar var) = dsId var \end{code} %************************************************************************ @@ -261,18 +262,25 @@ dsExpr expr@(HsCase discrim matches src_loc) matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code ) -dsExpr (ListComp expr quals) - = dsExpr expr `thenDs` \ core_expr -> - dsListComp core_expr quals - dsExpr (HsLet binds expr) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) -dsExpr (HsDoOut stmts then_id zero_id src_loc) +dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc) + | maybeToBool maybe_list_comp -- Special case for list comprehensions + = putSrcLocDs src_loc $ + dsListComp stmts elt_ty + + | otherwise = putSrcLocDs src_loc $ - dsDo then_id zero_id stmts + dsDo do_or_lc stmts return_id then_id zero_id result_ty + where + maybe_list_comp = case maybeAppTyCon result_ty of + Just (tycon, [elt_ty]) | tycon == listTyCon + -> Just elt_ty + other -> Nothing + Just elt_ty = maybe_list_comp dsExpr (HsIf guard_expr then_expr else_expr src_loc) = putSrcLocDs src_loc $ @@ -519,7 +527,7 @@ dsExpr (ClassDictLam dicts methods expr) #ifdef DEBUG -- HsSyn constructs that just shouldn't be here: -dsExpr (HsDo _ _) = panic "dsExpr:HsDo" +dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo" dsExpr (ExplicitList _) = panic "dsExpr:ExplicitList" dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" @@ -565,13 +573,13 @@ dsApp (TyApp expr tys) args -- we might should look out for SectionLs, etc., here, but we don't -dsApp (HsVar v) args - = lookupEnvDs v `thenDs` \ maybe_expr -> - mkAppDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) args - dsApp anything_else args = dsExpr anything_else `thenDs` \ core_expr -> mkAppDs core_expr args + +dsId v + = lookupEnvDs v `thenDs` \ maybe_expr -> + returnDs (case maybe_expr of { Nothing -> Var v; Just expr -> expr }) \end{code} \begin{code} @@ -611,47 +619,73 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with Basically does the translation given in the Haskell~1.3 report: \begin{code} -dsDo :: Id -- id for: (>>=) m - -> Id -- id for: zero m +dsDo :: DoOrListComp -> [TypecheckedStmt] + -> Id -- id for: return m + -> Id -- id for: (>>=) m + -> Id -- id for: zero m + -> Type -- Element type; the whole expression has type (m t) -> DsM CoreExpr -dsDo then_id zero_id (stmt:stmts) - = case stmt of - ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn - - ExprStmtOut expr locn a b -> - do_expr expr locn `thenDs` \ expr2 -> - ds_rest `thenDs` \ rest -> - newSysLocalDs a `thenDs` \ ignored_result_id -> - dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, - VarArg (mkValLam [ignored_result_id] rest)] - - LetStmt binds -> - dsBinds False binds `thenDs` \ binds2 -> - ds_rest `thenDs` \ rest -> - returnDs (mkCoLetsAny binds2 rest) - - BindStmtOut pat expr locn a b -> - do_expr expr locn `thenDs` \ expr2 -> - let - zero_expr = TyApp (HsVar zero_id) [b] - main_match - = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn)) - the_matches - = if failureFreePat pat - then [main_match] - else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)] - in - matchWrapper DoBindMatch the_matches "`do' statement" - `thenDs` \ (binders, matching_code) -> - dsApp (HsVar then_id) [TyArg a, TyArg b, - VarArg expr2, VarArg (mkValLam binders matching_code)] +dsDo do_or_lc stmts return_id then_id zero_id result_ty + = dsId return_id `thenDs` \ return_ds -> + dsId then_id `thenDs` \ then_ds -> + dsId zero_id `thenDs` \ zero_ds -> + let + (_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b) + + go [ReturnStmt expr] + = dsExpr expr `thenDs` \ expr2 -> + mkAppDs return_ds [TyArg b_ty, VarArg expr2] + + go (GuardStmt expr locn : stmts) + = do_expr expr locn `thenDs` \ expr2 -> + go stmts `thenDs` \ rest -> + mkAppDs zero_ds [TyArg b_ty] `thenDs` \ zero_expr -> + returnDs (mkCoreIfThenElse expr2 rest zero_expr) + + go (ExprStmt expr locn : stmts) + = do_expr expr locn `thenDs` \ expr2 -> + let + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + in + if null stmts then + returnDs expr2 + else + go stmts `thenDs` \ rest -> + newSysLocalDs a_ty `thenDs` \ ignored_result_id -> + mkAppDs then_ds [TyArg a_ty, TyArg b_ty, VarArg expr2, + VarArg (mkValLam [ignored_result_id] rest)] + + go (LetStmt binds : stmts ) + = dsBinds binds `thenDs` \ binds2 -> + go stmts `thenDs` \ rest -> + returnDs (mkCoLetsAny binds2 rest) + + go (BindStmt pat expr locn : stmts) + = putSrcLocDs locn $ + dsExpr expr `thenDs` \ expr2 -> + let + (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a) + zero_expr = TyApp (HsVar zero_id) [b_ty] + main_match = PatMatch pat (SimpleMatch ( + HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)) + the_matches + = if failureFreePat pat + then [main_match] + else [main_match, PatMatch (WildPat a_ty) (SimpleMatch zero_expr)] + in + matchWrapper DoBindMatch the_matches match_msg + `thenDs` \ (binders, matching_code) -> + mkAppDs then_ds [TyArg a_ty, TyArg b_ty, + VarArg expr2, VarArg (mkValLam binders matching_code)] + in + go stmts + where - ds_rest = dsDo then_id zero_id stmts do_expr expr locn = putSrcLocDs locn (dsExpr expr) -#ifdef DEBUG -dsDo then_expr zero_expr [] = panic "dsDo:[]" -#endif + match_msg = case do_or_lc of + DoStmt -> "`do' statement" + ListComp -> "comprehension" \end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 6b95110a28..c36e0bd58b 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -12,7 +12,8 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop import HsSyn ( GRHSsAndBinds(..), GRHS(..), - HsExpr, HsBinds ) + HsExpr, HsBinds + ) import TcHsSyn ( SYN_IE(TypecheckedGRHSsAndBinds), SYN_IE(TypecheckedGRHS), SYN_IE(TypecheckedPat), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) ) @@ -45,7 +46,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds -> DsM CoreExpr dsGuarded (GRHSsAndBindsOut grhss binds err_ty) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> case can_it_fail of CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) @@ -96,3 +97,4 @@ dsGRHS ty kind pats (GRHS guard expr locn) \end{code} + diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index d7e54ef40a..010d741291 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -36,6 +36,7 @@ outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats) outPatType (RecPat _ ty _) = ty outPatType (LitPat lit ty) = ty outPatType (NPat lit ty _) = ty +outPatType (NPlusKPat _ _ ty _ _) = ty outPatType (DictPat ds ms) = case (length ds_ms) of 0 -> unitTy 1 -> idType (head ds_ms) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 2a396ea7eb..bec2c8ac24 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,8 +11,8 @@ module DsListComp ( dsListComp ) where IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop -import HsSyn ( Qualifier(..), HsExpr, HsBinds ) -import TcHsSyn ( SYN_IE(TypecheckedQual), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) +import HsSyn ( Stmt(..), HsExpr, HsBinds ) +import TcHsSyn ( SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -37,42 +37,36 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. \begin{code} -dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr +dsListComp :: [TypecheckedStmt] + -> Type -- Type of list elements + -> DsM CoreExpr + +dsListComp quals elt_ty + | not opt_FoldrBuildOn -- Be boring + = deListComp quals nil_expr -dsListComp expr quals - = let - expr_ty = coreExprType expr + | otherwise -- foldr/build lives! + = newTyVarsDs [alphaTyVar] `thenDs` \ [n_tyvar] -> + let + alpha_to_alpha = alphaTy `mkFunTy` alphaTy + + n_ty = mkTyVarTy n_tyvar + c_ty = mkFunTys [elt_ty, n_ty] n_ty + g_ty = mkForAllTy alphaTyVar ( + (elt_ty `mkFunTy` alpha_to_alpha) + `mkFunTy` + alpha_to_alpha + ) in - if not opt_FoldrBuildOn then -- be boring - deListComp expr quals (nIL_EXPR expr_ty) - - else -- foldr/build lives! - new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) -> - let - alpha_to_alpha = alphaTy `mkFunTy` alphaTy - - c_ty = mkFunTys [expr_ty, n_ty] n_ty - g_ty = mkForAllTy alphaTyVar ( - (expr_ty `mkFunTy` alpha_to_alpha) - `mkFunTy` - alpha_to_alpha - ) - in - newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - - dfListComp expr expr_ty - c_ty c - n_ty n - quals `thenDs` \ result -> - - returnDs (mkBuild expr_ty n_tyvar c n g result) - where - nIL_EXPR ty = mkCon nilDataCon [] [ty] [] + newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - new_alpha_tyvar :: DsM (TyVar, Type) - new_alpha_tyvar - = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] -> - returnDs (new_ty, mkTyVarTy new_ty) + dfListComp c_ty c + n_ty n + quals `thenDs` \ result -> + + returnDs (mkBuild elt_ty n_tyvar c n g result) + where + nil_expr = mkCon nilDataCon [] [elt_ty] [] \end{code} %************************************************************************ @@ -119,23 +113,24 @@ is the TE translation scheme. Note that we carry around the @L@ list already desugared. @dsListComp@ does the top TE rule mentioned above. \begin{code} -deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr +deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr -deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above - = mkConDs consDataCon [TyArg (coreExprType expr), VarArg expr, VarArg list] +deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above + = dsExpr expr `thenDs` \ core_expr -> + mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list] -deListComp expr (FilterQual filt : quals) list -- rule B above - = dsExpr filt `thenDs` \ core_filt -> - deListComp expr quals list `thenDs` \ core_rest -> - returnDs ( mkCoreIfThenElse core_filt core_rest list ) +deListComp (GuardStmt guard locn : quals) list -- rule B above + = dsExpr guard `thenDs` \ core_guard -> + deListComp quals list `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp expr (LetQual binds : quals) list - = dsBinds False binds `thenDs` \ core_binds -> - deListComp expr quals list `thenDs` \ core_rest -> +deListComp (LetStmt binds : quals) list + = dsBinds binds `thenDs` \ core_binds -> + deListComp quals list `thenDs` \ core_rest -> returnDs (mkCoLetsAny core_binds core_rest) -deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above +deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> let u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing @@ -146,27 +141,14 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above res_ty = coreExprType core_list2 h_ty = u1_ty `mkFunTy` res_ty in - newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - `thenDs` \ [h', u1, u2, u3] -> - {- - Make the function h unfoldable by the deforester. - Since it only occurs once in the body, we can't get - an increase in code size by unfolding it. - -} - let - h = if False -- LATER: sw_chkr DoDeforest??? - then panic "deListComp:deforest" - -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest) - else h' - in - -- the "fail" value ... - mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> - - deListComp expr quals core_fail `thenDs` \ rest_expr -> + newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> - matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> - - mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> + -- the "fail" value ... + mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> + deListComp quals core_fail `thenDs` \ rest_expr -> + matchSimply (Var u2) pat res_ty + rest_expr core_fail `thenDs` \ core_match -> + mkAppDs (Var h) [VarArg core_list1] `thenDs` \ letrec_body -> returnDs ( mkCoLetrecAny [ @@ -174,8 +156,8 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above (Lam (ValBinder u1) (Case (Var u1) (AlgAlts - [(nilDataCon, [], core_list2), - (consDataCon, [u2, u3], core_match)] + [(nilDataCon, [], core_list2), + (consDataCon, [u2, u3], core_match)] NoDefault))) )] letrec_body ) @@ -196,29 +178,27 @@ TE << [ e | p <- l , q ] c n = foldr _ b -> b) n l \end{verbatim} \begin{code} -dfListComp :: CoreExpr -- the inside of the comp - -> Type -- the type of the inside - -> Type -> Id -- 'c'; its type and id +dfListComp :: Type -> Id -- 'c'; its type and id -> Type -> Id -- 'n'; its type and id - -> [TypecheckedQual] -- the rest of the qual's + -> [TypecheckedStmt] -- the rest of the qual's -> DsM CoreExpr -dfListComp expr expr_ty c_ty c_id n_ty n_id [] - = mkAppDs (Var c_id) [VarArg expr, VarArg (Var n_id)] +dfListComp c_ty c_id n_ty n_id [ReturnStmt expr] + = dsExpr expr `thenDs` \ core_expr -> + mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)] -dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals) - = dsExpr filt `thenDs` \ core_filt -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals - `thenDs` \ core_rest -> - returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id)) +dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals) + = dsExpr guard `thenDs` \ core_guard -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs (mkCoreIfThenElse core_guard core_rest (Var n_id)) -dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals) +dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals) -- new in 1.3, local bindings - = dsBinds False binds `thenDs` \ core_binds -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> - returnDs ( mkCoLetsAny core_binds core_rest ) + = dsBinds binds `thenDs` \ core_binds -> + dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + returnDs (mkCoLetsAny core_binds core_rest) -dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) +dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals) -- evaluate the two lists = dsExpr list1 `thenDs` \ core_list1 -> @@ -236,7 +216,7 @@ dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) -- build rest of the comprehesion - dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest -> + dfListComp c_ty c_id b_ty b quals `thenDs` \ core_rest -> -- build the pattern match matchSimply (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr -> diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi index fd329c0c69..26a0c4b313 100644 --- a/ghc/compiler/deSugar/DsLoop.lhi +++ b/ghc/compiler/deSugar/DsLoop.lhi @@ -26,6 +26,6 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it does -> DsM CoreExpr -dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] dsExpr :: TypecheckedHsExpr -> DsM CoreExpr \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index bf3f5f0878..38e567a7ea 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -20,8 +20,11 @@ module DsMonad ( SYN_IE(DsIdEnv), lookupId, - dsShadowError, - DsMatchContext(..), DsMatchKind(..), pprDsWarnings + dsShadowWarn, dsIncompleteWarn, + DsWarnings(..), + DsMatchContext(..), DsMatchKind(..), pprDsWarnings, + DsWarnFlavour -- Nuke with 1.4 + ) where IMP_Ubiq() @@ -60,8 +63,9 @@ type DsM result = -> DsWarnings -> (result, DsWarnings) -type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are - -- completely shadowed +type DsWarnings = Bag (DsWarnFlavour, DsMatchContext) + -- The desugarer reports matches which are + -- completely shadowed or incomplete patterns {-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -181,9 +185,13 @@ putSrcLocDs :: SrcLoc -> DsM a -> DsM a putSrcLocDs new_loc expr us old_loc mod_and_grp env warns = expr us new_loc mod_and_grp env warns -dsShadowError :: DsMatchContext -> DsM () -dsShadowError cxt us loc mod_and_grp env warns - = ((), warns `snocBag` cxt) +dsShadowWarn :: DsMatchContext -> DsM () +dsShadowWarn cxt us loc mod_and_grp env warns + = ((), warns `snocBag` (Shadowed, cxt)) + +dsIncompleteWarn :: DsMatchContext -> DsM () +dsIncompleteWarn cxt us loc mod_and_grp env warns + = ((), warns `snocBag` (Incomplete, cxt)) \end{code} \begin{code} @@ -237,9 +245,12 @@ lookupId env id %************************************************************************ \begin{code} +data DsWarnFlavour = Shadowed | Incomplete deriving () + data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext + deriving () data DsMatchKind = FunMatch Id @@ -247,23 +258,31 @@ data DsMatchKind | LambdaMatch | PatBindMatch | DoBindMatch + deriving () -pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty +pprDsWarnings :: PprStyle -> DsWarnings -> Pretty pprDsWarnings sty warns - = ppAboves (map pp_cxt (bagToList warns)) + = ppAboves (map pp_warn (bagToList warns)) where - pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what") - pp_cxt (DsMatchContext kind pats loc) - = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) - 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:")) + pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"), + case flavour of + Shadowed -> ppPStr SLIT("shadowed") + Incomplete -> ppPStr SLIT("possibly incomplete")] + + pp_warn (flavour, DsMatchContext kind pats loc) + = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")]) + 4 (ppHang msg 4 (pp_match kind pats)) + where + msg = case flavour of + Shadowed -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped") + Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns") pp_match (FunMatch fun) pats - = ppHang (ppr sty fun) - 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")]) + = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a case alternative:")) + = ppHang (ppPStr SLIT("in a group of case alternative beginning:")) 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) pp_match PatBindMatch pats diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index ff2ec5fe45..3fdc1d3c9a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -31,7 +31,7 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity, - Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) + Match, HsBinds, Stmt, DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedPat) ) import DsHsSyn ( outPatType ) import CoreSyn @@ -46,21 +46,20 @@ import Id ( idType, dataConArgTys, -- pprId{-ToDo:rm-}, SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) +import PprType ( GenType, GenTyVar ) import TyCon ( isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy, - mkTheta, isUnboxedType, applyTyCon, getAppTyCon + mkTheta, isUnboxedType, applyTyCon, getAppTyCon, + GenType {- instances -} ) +import TyVar ( GenTyVar {- instances -} ) import TysPrim ( voidTy ) import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +import Unique ( Unique ) import Usage ( SYN_IE(UVar) ) import SrcLoc ( SrcLoc {- instance Outputable -} ) ---import PprCore{-ToDo:rm-} ---import PprType--ToDo:rm ---import Pretty--ToDo:rm ---import TyVar--ToDo:rm ---import Unique--ToDo:rm \end{code} %************************************************************************ @@ -316,7 +315,7 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = getSrcLocDs `thenDs` \ src_loc -> let - full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg]) + full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr "|", ppStr msg]) msg_lit = NoRepStr (_PK_ full_msg) in returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) @@ -356,7 +355,7 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr = if is_simple_tuple_pat pat then mkTupleBind tyvars [] locals_and_globals val_expr else - mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg -> + mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty pat_string `thenDs` \ error_msg -> matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> mkTupleBind tyvars [] locals_and_globals tuple_expr where @@ -369,6 +368,8 @@ mkSelectorBinds tyvars pat locals_and_globals val_expr is_var_pat (VarPat v) = True is_var_pat other = False -- Even wild-card patterns aren't acceptable + + pat_string = ppShow 80 (ppr PprForUser pat) \end{code} We're about to match against some patterns. We want to make some diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c822765110..7fb28b1c05 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -153,31 +153,27 @@ And gluing the ``success expressions'' together isn't quite so pretty. \begin{code} match [] eqns_info shadows - = pin_eqns eqns_info `thenDs` \ match_result@(MatchResult _ _ _ cxt) -> + = complete_matches eqns_info (any eqn_cant_fail shadows) + where + complete_matches [eqn] is_shadowed + = complete_match eqn is_shadowed + + complete_matches (eqn:eqns) is_shadowed + = complete_match eqn is_shadowed `thenDs` \ match_result1 -> + complete_matches eqns (is_shadowed || eqn_cant_fail eqn) `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 -- If at this stage we find that at least one of the shadowing -- equations is guaranteed not to fail, then warn of an overlapping pattern - if not (all shadow_can_fail shadows) then - dsShadowError cxt `thenDs` \ _ -> - returnDs match_result - else - returnDs match_result - - where - pin_eqns [EqnInfo [] match_result] = returnDs match_result - -- Last eqn... can't have pats ... - - pin_eqns (EqnInfo [] match_result1 : more_eqns) - = pin_eqns more_eqns `thenDs` \ match_result2 -> - combineMatchResults match_result1 match_result2 + complete_match (EqnInfo [] match_result@(MatchResult _ _ _ cxt)) is_shadowed + | is_shadowed = dsShadowWarn cxt `thenDs` \ _ -> + returnDs match_result - pin_eqns other_pat = panic "match: pin_eqns" + | otherwise = returnDs match_result - shadow_can_fail :: EquationInfo -> Bool - - shadow_can_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = True - shadow_can_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = False - shadow_can_fail other = panic "match:shadow_can_fail" + eqn_cant_fail :: EquationInfo -> Bool + eqn_cant_fail (EqnInfo [] (MatchResult CanFail _ _ _)) = False + eqn_cant_fail (EqnInfo [] (MatchResult CantFail _ _ _)) = True \end{code} %************************************************************************ @@ -253,6 +249,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. Removing lazy (irrefutable) patterns (you don't want to know...). \item Converting explicit tuple- and list-pats into ordinary @ConPats@. +\item +Convert the literal pat "" to []. \end{itemize} The result of this tidying is that the column of patterns will include @@ -395,6 +393,7 @@ tidy1 v pat@(LitPat lit lit_ty) match_result -- NPats: we *might* be able to replace these w/ a simpler form + tidy1 v pat@(NPat lit lit_ty _) match_result = returnDs (better_pat, match_result) where @@ -405,6 +404,10 @@ tidy1 v pat@(NPat lit lit_ty _) match_result | lit_ty `eqTy` addrTy = ConPat addrDataCon lit_ty [LitPat (mk_addr lit) addrPrimTy] | lit_ty `eqTy` floatTy = ConPat floatDataCon lit_ty [LitPat (mk_float lit) floatPrimTy] | lit_ty `eqTy` doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] + + -- Convert the literal pattern "" to the constructor pattern []. + | null_str_lit lit = ConPat nilDataCon lit_ty [] + | otherwise = pat mk_int (HsInt i) = HsIntPrim i @@ -425,6 +428,9 @@ tidy1 v pat@(NPat lit lit_ty _) match_result mk_double (HsFrac f) = HsDoublePrim f mk_double l@(HsLitLit s) = l + null_str_lit (HsString s) = _NULL_ s + null_str_lit other_lit = False + -- and everything else goes through unchanged... tidy1 v non_interesting_pat match_result @@ -608,7 +614,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string matchWrapper kind [(GRHSMatch (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ([], mkCoLetsAny core_binds core_expr) @@ -622,8 +628,14 @@ matchWrapper kind matches error_string match new_vars eqns_info [] `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> + -- Check for incomplete pattern match + (case match_result of + MatchResult CanFail result_ty match_fn cxt -> dsIncompleteWarn cxt + other -> returnDs () + ) `thenDs` \ _ -> + + extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) \end{code} @@ -664,8 +676,8 @@ matchSimply scrut_expr pat result_ty result_expr msg extractMatchResult (MatchResult CantFail _ match_fn _) fail_expr = returnDs (match_fn (error "It can't fail!")) -extractMatchResult (MatchResult CanFail result_ty match_fn _) fail_expr - = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> +extractMatchResult (MatchResult CanFail result_ty match_fn cxt) fail_expr + = mkFailurePair result_ty `thenDs` \ (fail_bind_fn, if_it_fails) -> returnDs (Let (fail_bind_fn fail_expr) (match_fn if_it_fails)) \end{code} @@ -699,7 +711,7 @@ flattenMatches kind (match : matches) = flatten_match (pat:pats_so_far) match flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds False binds `thenDs` \ core_binds -> + = dsBinds binds `thenDs` \ core_binds -> dsGRHSs ty kind pats grhss `thenDs` \ match_result -> returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where @@ -707,12 +719,14 @@ flattenMatches kind (match : matches) flatten_match pats_so_far (SimpleMatch expr) = dsExpr expr `thenDs` \ core_expr -> + getSrcLocDs `thenDs` \ locn -> returnDs (EqnInfo pats (MatchResult CantFail (coreExprType core_expr) (\ ignore -> core_expr) - NoMatchContext)) - -- The NoMatchContext is just a place holder. In a simple match, - -- the matching can't fail, so we won't generate an error message. - where - pats = reverse pats_so_far -- They've accumulated in reverse order + (DsMatchContext kind pats locn))) + + -- the matching can't fail, so we won't generate an error message. + where + pats = reverse pats_so_far -- They've accumulated in reverse order + \end{code} diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index a4ed52d685..c7e4bc1d9c 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -12,11 +12,12 @@ IMP_Ubiq() IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity, - Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo ) + Match, HsBinds, Stmt(..), DoOrListComp, HsType, ArithSeqInfo ) import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedPat) ) -import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) ) +import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr(..), GenCoreBinding(..) ) +import Id ( GenId {- instance Eq -} ) import DsMonad import DsUtils @@ -54,9 +55,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps match_prims_used vars eqns_info@(EqnInfo ((LitPat literal lit_ty):ps1) _ : eqns) shadows = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit literal eqns_info + = partitionEqnsByLit Nothing literal eqns_info (shifted_shadows_for_this_lit, shadows_not_for_this_lit) - = partitionEqnsByLit literal shadows + = partitionEqnsByLit Nothing literal shadows in -- recursive call to make other alts... match_prims_used vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ rest_of_alts -> @@ -85,9 +86,9 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo (LitPat literal lit_ty : ps matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPat literal lit_ty eq_chk):ps1) _ : eqns) shadows = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit literal eqns_info + = partitionEqnsByLit Nothing literal eqns_info (shifted_shadows_for_this_lit, shadows_not_for_this_lit) - = partitionEqnsByLit literal shadows + = partitionEqnsByLit Nothing literal shadows in dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr -> match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> @@ -111,12 +112,42 @@ We generate: <try-next-pattern-or-whatever> \end{verbatim} + +\begin{code} +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo ((NPlusKPat master_n k ty ge sub):ps1) _ : eqns) shadows + = let + (shifted_eqns_for_this_lit, eqns_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k eqns_info + (shifted_shadows_for_this_lit, shadows_not_for_this_lit) + = partitionEqnsByLit (Just master_n) k shadows + in + match vars shifted_eqns_for_this_lit shifted_shadows_for_this_lit `thenDs` \ inner_match_result -> + + dsExpr (HsApp ge (HsVar var)) `thenDs` \ ge_expr -> + dsExpr (HsApp sub (HsVar var)) `thenDs` \ nminusk_expr -> + + mkGuardedMatchResult + ge_expr + (mkCoLetsMatchResult [NonRec master_n nminusk_expr] inner_match_result) + `thenDs` \ match_result1 -> + + if (null eqns_not_for_this_lit) + then + returnDs match_result1 + else + matchLiterals all_vars eqns_not_for_this_lit shadows_not_for_this_lit `thenDs` \ match_result2 -> + combineMatchResults match_result1 match_result2 +\end{code} + Given a blob of LitPats/NPats, we want to split them into those that are ``same''/different as one we are looking at. We need to know whether we're looking at a LitPat/NPat, and what literal we're after. \begin{code} -partitionEqnsByLit :: HsLit +partitionEqnsByLit :: Maybe Id -- (Just v) for N-plus-K patterns, where v + -- is the "master" variable; + -- Nothing for NPats and LitPats + -> HsLit -> [EquationInfo] -> ([EquationInfo], -- These ones are for this lit, AND -- they've been "shifted" by stripping @@ -125,27 +156,34 @@ partitionEqnsByLit :: HsLit -- are exactly as fed in. ) -partitionEqnsByLit lit eqns +partitionEqnsByLit nPlusK lit eqns = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) - (unzip (map (partition_eqn lit) eqns)) + (unzip (map (partition_eqn nPlusK lit) eqns)) where - partition_eqn :: HsLit -> EquationInfo -> + partition_eqn :: Maybe Id -> HsLit -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) - partition_eqn lit (EqnInfo (LitPat k _ : remaining_pats) match_result) + partition_eqn Nothing lit (EqnInfo (LitPat k _ : remaining_pats) match_result) | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) - -- NB the pattern is stripped off thhe EquationInfo + -- NB the pattern is stripped off the EquationInfo - partition_eqn lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) + partition_eqn Nothing lit (EqnInfo (NPat k _ _ : remaining_pats) match_result) | lit `eq_lit` k = (Just (EqnInfo remaining_pats match_result), Nothing) - -- NB the pattern is stripped off thhe EquationInfo + -- NB the pattern is stripped off the EquationInfo + + partition_eqn (Just master_n) lit (EqnInfo (NPlusKPat n k _ _ _ : remaining_pats) match_result) + | lit `eq_lit` k = (Just (EqnInfo remaining_pats new_match_result), Nothing) + -- NB the pattern is stripped off the EquationInfo + where + new_match_result | master_n == n = match_result + | otherwise = mkCoLetsMatchResult [NonRec n (Var master_n)] match_result -- Wild-card patterns, which will only show up in the shadows, go into both groups - partition_eqn lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) + partition_eqn nPlusK lit eqn@(EqnInfo (WildPat _ : remaining_pats) match_result) = (Just (EqnInfo remaining_pats match_result), Just eqn) -- Default case; not for this pattern - partition_eqn lit eqn = (Nothing, Just eqn) + partition_eqn nPlusK lit eqn = (Nothing, Just eqn) -- ToDo: meditate about this equality business... |