diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 3 | ||||
| -rw-r--r-- | compiler/deSugar/DsArrows.hs | 103 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 91 | ||||
| -rw-r--r-- | compiler/deSugar/DsCCall.hs | 5 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 177 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs-boot | 6 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.hs | 11 | ||||
| -rw-r--r-- | compiler/deSugar/DsGRHSs.hs | 5 | ||||
| -rw-r--r-- | compiler/deSugar/DsListComp.hs | 39 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 138 | ||||
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 4 | ||||
| -rw-r--r-- | compiler/deSugar/Match.hs | 18 | ||||
| -rw-r--r-- | compiler/deSugar/MatchCon.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/PmExpr.hs | 2 |
14 files changed, 464 insertions, 140 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 1f6effa6b9..7faf8fb8ec 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -21,6 +21,7 @@ import HsSyn import Module import Outputable import DynFlags +import ConLike import Control.Monad import SrcLoc import ErrUtils @@ -509,6 +510,8 @@ addBinTickLHsExpr boxLabel (L pos e0) addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" +addTickHsExpr e@(HsConLikeOut con) + | Just id <- conLikeWrapId_maybe con = do freeVar id; return e addTickHsExpr e@(HsIPVar _) = return e addTickHsExpr e@(HsOverLit _) = return e addTickHsExpr e@(HsOverLabel _) = return e diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 93af69ba89..f686b68947 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -25,9 +25,10 @@ import qualified HsUtils -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import TcType +import Type ( splitPiTy ) import TcEvidence import CoreSyn import CoreFVs @@ -38,7 +39,7 @@ import DsBinds (dsHsWrapper) import Name import Var import Id -import DataCon +import ConLike import TysWiredIn import BasicTypes import PrelNames @@ -46,7 +47,7 @@ import Outputable import Bag import VarSet import SrcLoc -import ListSetOps( assocDefault ) +import ListSetOps( assocMaybe ) import Data.List import Util import UniqDFM @@ -59,23 +60,67 @@ mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv) -- See Note [CmdSyntaxTable] in HsExpr mkCmdEnv tc_meths = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths + + -- NB: Some of these lookups might fail, but that's OK if the + -- symbol is never used. That's why we use Maybe first and then + -- panic. An eager panic caused trouble in typecheck/should_compile/tc192 + ; let the_arr_id = assocMaybe prs arrAName + the_compose_id = assocMaybe prs composeAName + the_first_id = assocMaybe prs firstAName + the_app_id = assocMaybe prs appAName + the_choice_id = assocMaybe prs choiceAName + the_loop_id = assocMaybe prs loopAName + + -- used as an argument in, e.g., do_premap + ; check_lev_poly 3 the_arr_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 5 the_compose_id + + -- used as an argument in, e.g., dsCmdStmt/BodyStmt + ; check_lev_poly 4 the_first_id + + -- the result of the_app_id is used as an argument in, e.g., + -- dsCmd/HsCmdArrApp/HsHigherOrderApp + ; check_lev_poly 2 the_app_id + + -- used as an argument in, e.g., HsCmdIf + ; check_lev_poly 5 the_choice_id + + -- used as an argument in, e.g., RecStmt + ; check_lev_poly 4 the_loop_id + ; return (meth_binds, DsCmdEnv { - arr_id = Var (find_meth prs arrAName), - compose_id = Var (find_meth prs composeAName), - first_id = Var (find_meth prs firstAName), - app_id = Var (find_meth prs appAName), - choice_id = Var (find_meth prs choiceAName), - loop_id = Var (find_meth prs loopAName) + arr_id = Var (unmaybe the_arr_id arrAName), + compose_id = Var (unmaybe the_compose_id composeAName), + first_id = Var (unmaybe the_first_id firstAName), + app_id = Var (unmaybe the_app_id appAName), + choice_id = Var (unmaybe the_choice_id choiceAName), + loop_id = Var (unmaybe the_loop_id loopAName) }) } where mk_bind (std_name, expr) = do { rhs <- dsExpr expr - ; id <- newSysLocalDs (exprType rhs) + ; id <- newSysLocalDs (exprType rhs) -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } - find_meth prs std_name - = assocDefault (mk_panic std_name) prs std_name - mk_panic std_name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr std_name) + unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name) + unmaybe (Just id) _ = id + + -- returns the result type of a pi-type (that is, a forall or a function) + -- Note that this result type may be ill-scoped. + res_type :: Type -> Type + res_type ty = res_ty + where + (_, res_ty) = splitPiTy ty + + check_lev_poly :: Int -- arity + -> Maybe Id -> DsM () + check_lev_poly _ Nothing = return () + check_lev_poly arity (Just id) + = dsNoLevPoly (nTimes arity res_type (idType id)) + (text "In the result of the function" <+> quotes (ppr id)) + -- arr :: forall b c. (b -> c) -> a b c do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr @@ -320,7 +365,7 @@ dsCmd ids local_vars stack_ty res_ty let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - core_arrow <- dsLExpr arrow + core_arrow <- dsLExprNoLP arrow core_arg <- dsLExpr arg stack_id <- newSysLocalDs stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg @@ -376,7 +421,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do (core_cmd, free_vars, env_ids') <- dsfixCmd ids local_vars stack_ty' res_ty cmd stack_id <- newSysLocalDs stack_ty - arg_id <- newSysLocalDs arg_ty + arg_id <- newSysLocalDsNoLP arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id) @@ -409,7 +454,7 @@ dsCmd ids local_vars stack_ty res_ty local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body - param_ids <- mapM newSysLocalDs pat_tys + param_ids <- mapM newSysLocalDsNoLP pat_tys stack_id' <- newSysLocalDs stack_ty' -- the expression is built from the inside out, so the actions @@ -527,8 +572,8 @@ dsCmd ids local_vars stack_ty res_ty left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName let - left_id = HsVar (noLoc (dataConWrapId left_con)) - right_id = HsVar (noLoc (dataConWrapId right_con)) + left_id = HsConLikeOut (RealDataCon left_con) + right_id = HsConLikeOut (RealDataCon right_con) left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e @@ -565,7 +610,7 @@ dsCmd ids local_vars stack_ty res_ty -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet lbinds@(L _ binds) body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) local_vars' = defined_vars `unionVarSet` local_vars @@ -573,7 +618,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body stack_id <- newSysLocalDs stack_ty -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id) + core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id) -- match the old environment and stack against the input core_map <- matchEnvStack env_ids stack_id core_binds return (do_premap ids @@ -590,7 +635,10 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do -- -- ---> premap (\ (env,stk) -> env) c -dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do +dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo (L loc stmts) stmts_ty) env_ids = do + putSrcSpanDs loc $ + dsNoLevPoly stmts_ty + (text "In the do-command:" <+> ppr do_block) (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids let env_ty = mkBigCoreVarTupTy env_ids core_fst <- mkFstExpr env_ty stack_ty @@ -656,7 +704,9 @@ dsfixCmd DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd - = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) + = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty + (text "When desugaring the command:" <+> ppr cmd) + ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } -- Feed back the list of local variables actually used a command, -- for use as the input tuple of the generated arrow. @@ -697,7 +747,9 @@ dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -- -- ---> premap (\ (xs) -> ((xs), ())) c -dsCmdDo ids local_vars res_ty [L _ (LastStmt body _ _)] env_ids = do +dsCmdDo ids local_vars res_ty [L loc (LastStmt body _ _)] env_ids = do + putSrcSpanDs loc $ dsNoLevPoly res_ty + (text "In the command:" <+> ppr body) (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids let env_ty = mkBigCoreVarTupTy env_ids env_var <- newSysLocalDs env_ty @@ -765,6 +817,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do out_ty = mkBigCoreVarTupTy out_ids before_c_ty = mkCorePairTy in_ty1 out_ty after_c_ty = mkCorePairTy c_ty out_ty + dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here snd_fn <- mkSndExpr c_ty out_ty return (do_premap ids in_ty before_c_ty out_ty core_mux $ do_compose ids before_c_ty after_c_ty out_ty @@ -834,7 +887,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do +dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do -- build a new environment using the let bindings core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) -- match the old environment against the input @@ -1004,6 +1057,8 @@ dsfixCmdStmts dsfixCmdStmts ids local_vars out_ids stmts = trimInput (dsCmdStmts ids local_vars out_ids stmts) + -- TODO: Add levity polymorphism check for the resulting expression. + -- But I (Richard E.) don't know enough about arrows to do so. dsCmdStmts :: DsCmdEnv -- arrow combinators diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 833d3570b3..ae18ffdf43 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -58,7 +58,7 @@ import SrcLoc import Maybes import OrdList import Bag -import BasicTypes hiding ( TopLevel ) +import BasicTypes import DynFlags import FastString import Util @@ -75,24 +75,42 @@ import Control.Monad -- | Desugar top level binds, strict binds are treated like normal -- binds since there is no good time to force before first usage. dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) -dsTopLHsBinds binds = fmap (toOL . snd) (ds_lhs_binds binds) +dsTopLHsBinds binds + -- see Note [Strict binds checks] + | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds) + = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds + ; mapBagM_ (top_level_err "strict pattern bindings") bang_binds + ; return nilOL } --- | Desugar all other kind of bindings, Ids of strict binds are returned to --- later be forced in the binding gorup body, see Note [Desugar Strict binds] -dsLHsBinds :: LHsBinds Id - -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBinds binds = do { (force_vars, binds') <- ds_lhs_binds binds - ; return (force_vars, binds') } + | otherwise + = do { (force_vars, prs) <- dsLHsBinds binds + ; when debugIsOn $ + do { xstrict <- xoptM LangExt.Strict + ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) } + -- with -XStrict, even top-level vars are listed as force vars. ------------------------- + ; return (toOL prs) } + + where + unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds + bang_binds = filterBag (isBangedPatBind . unLoc) binds + + top_level_err desc (L loc bind) + = putSrcSpanDs loc $ + errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:") + 2 (ppr bind)) -ds_lhs_binds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) -ds_lhs_binds binds - = do { ds_bs <- mapBagM dsLHsBind binds +-- | Desugar all other kind of bindings, Ids of strict binds are returned to +-- later be forced in the binding gorup body, see Note [Desugar Strict binds] +dsLHsBinds :: LHsBinds Id -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds binds + = do { MASSERT( allBag (not . isUnliftedHsBind . unLoc) binds ) + ; ds_bs <- mapBagM dsLHsBind binds ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b')) id ([], []) ds_bs) } +------------------------ dsLHsBind :: LHsBind Id -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBind (L loc bind) = do dflags <- getDynFlags @@ -168,7 +186,7 @@ dsHsBind dflags = -- See Note [AbsBinds wrappers] in HsBinds addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check - do { (_, bind_prs) <- ds_lhs_binds binds + do { (_, bind_prs) <- dsLHsBinds binds ; let core_bind = Rec bind_prs ; ds_binds <- dsTcEvBinds_s ev_binds ; core_wrap <- dsHsWrapper wrap -- Usually the identity @@ -192,7 +210,7 @@ dsHsBind dflags (AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_exports = exports , abs_ev_binds = ev_binds, abs_binds = binds }) - = do { (force_vars, bind_prs) <- ds_lhs_binds binds + = do { (force_vars, bind_prs) <- dsLHsBinds binds ; let mk_bind (ABE { abe_wrap = wrap , abe_poly = global , abe_mono = local @@ -213,7 +231,7 @@ dsHsBind dflags -- See Note [Desugaring AbsBinds] = addDictsDs (toTcTypeBag (listToBag dicts)) $ -- addDictsDs: push type constraints deeper for pattern match check - do { (local_force_vars, bind_prs) <- ds_lhs_binds binds + do { (local_force_vars, bind_prs) <- dsLHsBinds binds ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs | (lcl_id, rhs) <- bind_prs ] -- Monomorphic recursion possible, hence Rec @@ -590,6 +608,38 @@ tuple `t`, thus: See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more detailed explanation of the desugaring of strict bindings. +Note [Strict binds checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several checks around properly formed strict bindings. They +all link to this Note. These checks must be here in the desugarer because +we cannot know whether or not a type is unlifted until after zonking, due +to levity polymorphism. These checks all used to be handled in the typechecker +in checkStrictBinds (before Jan '17). + +We define an "unlifted bind" to be any bind that binds an unlifted id. Note that + + x :: Char + (# True, x #) = blah + +is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind. + +Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedPatBind. +Define a "strict bind" to be either an unlifted bind or a banged bind. + +The restrictions are: + 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. + + 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged + unlifted bind, but an unbanged bind looks lazy, and we don't want users to be + surprised by the strictness of an unlifted bind.) Checked in first clause + of DsExpr.ds_val_bind. + + 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type + variables or constraints.) Checked in first clause + of DsExpr.ds_val_bind. + + 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. + -} ------------------------ @@ -1056,11 +1106,16 @@ dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; return (w1 . w2) } -dsHsWrapper (WpFun c1 c2 t1) = do { x <- newSysLocalDs t1 + -- See comments on WpFun in TcEvidence for an explanation of what + -- the specification of this clause is +dsHsWrapper (WpFun c1 c2 t1 doc) + = do { x <- newSysLocalDsNoLP t1 ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - ; return (\e -> Lam x (w2 (app e (w1 (Var x))))) } + arg = w1 (Var x) + ; dsNoLevPolyExpr arg doc + ; return (\e -> (Lam x (w2 (app e arg)))) } dsHsWrapper (WpCast co) = ASSERT(coercionRole co == Representational) return $ \e -> mkCastDs e co dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm @@ -1106,6 +1161,8 @@ dsEvTerm (EvCast tm co) dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms ; return $ Var df `mkTyApps` tys `mkApps` tms' } + -- The use of mkApps here is OK vis-a-vis levity polymorphism because + -- the terms are always evidence variables with types of kind Constraint dsEvTerm (EvCoercion co) = return (Coercion co) dsEvTerm (EvSuperClass d n) diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index d7cba6567f..b90dd80965 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -84,6 +84,7 @@ follows: dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) + -- Precondition: none have levity-polymorphic types -> Safety -- Safety of the call -> Type -- Type of the result: IO t -> DsM CoreExpr -- Result, of type ??? @@ -122,7 +123,7 @@ mkFCall dflags uniq the_fcall val_args res_ty ty = mkInvForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty -unboxArg :: CoreExpr -- The supplied argument +unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic -> DsM (CoreExpr, -- To pass as the actual argument CoreExpr -> CoreExpr -- Wrapper to unbox the arg ) @@ -130,6 +131,8 @@ unboxArg :: CoreExpr -- The supplied argument -- (x#::Int#, \W. case x of I# x# -> W) -- where W is a CoreExpr that probably mentions x# +-- always returns a non-levity-polymorphic expression + unboxArg arg -- Primtive types: nothing to unbox | isPrimitiveType arg_ty diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 8025c69aeb..575b510e34 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -6,9 +6,9 @@ Desugaring exporessions. -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} -module DsExpr ( dsExpr, dsLExpr, dsLocalBinds +module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds , dsValBinds, dsLit, dsSyntaxExpr ) where #include "HsVersions.h" @@ -41,6 +41,7 @@ import MkCore import DynFlags import CostCentre import Id +import MkId import Module import ConLike import DataCon @@ -65,12 +66,14 @@ import Control.Monad ************************************************************************ -} -dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr -dsLocalBinds EmptyLocalBinds body = return body -dsLocalBinds (HsValBinds binds) body = dsValBinds binds body -dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body +dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds (L _ EmptyLocalBinds) body = return body +dsLocalBinds (L loc (HsValBinds binds)) body = putSrcSpanDs loc $ + dsValBinds binds body +dsLocalBinds (L _ (HsIPBinds binds)) body = dsIPBinds binds body ------------------------- +-- caller sets location dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds dsValBinds (ValBindsIn {}) _ = panic "dsValBinds ValBindsIn" @@ -89,25 +92,72 @@ dsIPBinds (IPBinds ip_binds ev_binds) body return (Let (NonRec n e') body) ------------------------- +-- caller sets location ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds, + | [L loc bind] <- bagToList hsbinds -- Non-recursive, non-overloaded bindings only come in ones -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) - unliftedMatchOnly bind - = putSrcSpanDs loc (dsUnliftedBind bind body) + , isUnliftedHsBind bind + = putSrcSpanDs loc $ + -- see Note [Strict binds checks] in DsBinds + if is_polymorphic bind + then errDsCoreExpr (poly_bind_err bind) + -- data Ptr a = Ptr Addr# + -- f x = let p@(Ptr y) = ... in ... + -- Here the binding for 'p' is polymorphic, but does + -- not mix with an unlifted binding for 'y'. You should + -- use a bang pattern. Trac #6078. + + else do { when (looksLazyPatBind bind) $ + warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind) + -- Complain about a binding that looks lazy + -- e.g. let I# y = x in ... + -- Remember, in checkStrictBinds we are going to do strict + -- matching, so (for software engineering reasons) we insist + -- that the strictness is manifest on each binding + -- However, lone (unboxed) variables are ok + + + ; dsUnliftedBind bind body } + where + is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic (AbsBindsSig { abs_tvs = tvs, abs_ev_vars = evs }) + = not (null tvs && null evs) + is_polymorphic _ = False + + unlifted_must_be_bang bind + = hang (text "Pattern bindings containing unlifted types should use" $$ + text "an outermost bang pattern:") + 2 (ppr bind) + + poly_bind_err bind + = hang (text "You can't mix polymorphic and unlifted bindings:") + 2 (ppr bind) $$ + text "Probable fix: add a type signature" + +ds_val_bind (is_rec, binds) _body + | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds + = ASSERT( isRec is_rec ) + errDsCoreExpr $ + hang (text "Recursive bindings for unlifted types aren't allowed:") + 2 (vcat (map ppr (bagToList binds))) -- Ordinary case for bindings; none should be unlifted -ds_val_bind (_is_rec, binds) body - = do { (force_vars,prs) <- dsLHsBinds binds +ds_val_bind (is_rec, binds) body + = do { MASSERT( isRec is_rec || isSingletonBag binds ) + -- we should never produce a non-recursive list of multiple binds + + ; (force_vars,prs) <- dsLHsBinds binds ; let body' = foldr seqVar body force_vars - ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr _is_rec $$ ppr binds ) + ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds ) case prs of [] -> return body _ -> return (Let (Rec prs) body') } @@ -170,20 +220,6 @@ dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ----------------------- -unliftedMatchOnly :: HsBind Id -> Bool -unliftedMatchOnly (AbsBinds { abs_binds = lbinds }) - = anyBag (unliftedMatchOnly . unLoc) lbinds -unliftedMatchOnly (AbsBindsSig { abs_sig_bind = L _ bind }) - = unliftedMatchOnly bind -unliftedMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty }) - = isUnliftedType rhs_ty - || isUnliftedLPat lpat - || any (isUnliftedType . idType) (collectPatBinders lpat) -unliftedMatchOnly (FunBind { fun_id = L _ id }) - = isUnliftedType (idType id) -unliftedMatchOnly _ = False -- I hope! Checked immediately by caller in fact - {- ************************************************************************ * * @@ -194,7 +230,26 @@ unliftedMatchOnly _ = False -- I hope! Checked immediately by caller in fact dsLExpr :: LHsExpr Id -> DsM CoreExpr -dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e +dsLExpr (L loc e) + = putSrcSpanDs loc $ + do { core_expr <- dsExpr e + -- uncomment this check to test the hsExprType function in TcHsSyn + -- ; MASSERT2( exprType core_expr `eqType` hsExprType e + -- , ppr e <+> dcolon <+> ppr (hsExprType e) $$ + -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr) ) + ; return core_expr } + +-- | Variant of 'dsLExpr' that ensures that the result is not levity +-- polymorphic. This should be used when the resulting expression will +-- be an argument to some other function. +-- See Note [Levity polymorphism checking] in DsMonad +-- See Note [Levity polymorphism invariants] in CoreSyn +dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr +dsLExprNoLP (L loc e) + = putSrcSpanDs loc $ + do { e' <- dsExpr e + ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e) + ; return e' } dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e @@ -202,6 +257,7 @@ dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) -- See Note [Desugaring vars] dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them +dsExpr (HsConLikeOut con) = return (dsConLike con) dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar" dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel" dsExpr (HsLit lit) = dsLit lit @@ -227,7 +283,7 @@ dsExpr (HsLamCase matches) ; return $ Lam discrim_var matching_code } dsExpr e@(HsApp fun arg) - = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg + = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExprNoLP arg dsExpr (HsAppTypeOut e _) -- ignore type arguments here; they're in the wrappers instead at this point @@ -275,10 +331,10 @@ will sort it out. dsExpr e@(OpApp e1 op _ e2) = -- for the type of y, we need the type of op's 2nd argument - mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2] + mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExprNoLP [e1, e2] dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) - = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr + = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExprNoLP expr -- dsLExpr (SectionR op expr) -- \ x -> op x expr dsExpr e@(SectionR op expr) = do @@ -287,8 +343,8 @@ dsExpr e@(SectionR op expr) = do let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) -- See comment with SectionL y_core <- dsLExpr expr - x_id <- newSysLocalDs x_ty - y_id <- newSysLocalDs y_ty + x_id <- newSysLocalDsNoLP x_ty + y_id <- newSysLocalDsNoLP y_ty return (bindNonRec y_id y_core $ Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) @@ -296,7 +352,7 @@ dsExpr (ExplicitTuple tup_args boxity) = do { let go (lam_vars, args) (L _ (Missing ty)) -- For every missing expression, we need -- another lambda in the desugaring. - = do { lam_var <- newSysLocalDs ty + = do { lam_var <- newSysLocalDsNoLP ty ; return (lam_var : lam_vars, Var lam_var : args) } go (lam_vars, args) (L _ (Present expr)) -- Expressions that are present don't generate @@ -338,7 +394,7 @@ dsExpr (HsCase discrim matches) -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -dsExpr (HsLet (L _ binds) body) = do +dsExpr (HsLet binds body) = do body' <- dsLExpr body dsLocalBinds binds body' @@ -391,7 +447,7 @@ dsExpr (ExplicitPArr ty []) = do dsExpr (ExplicitPArr ty xs) = do singletonP <- dsDPHBuiltin singletonPVar appP <- dsDPHBuiltin appPVar - xs' <- mapM dsLExpr xs + xs' <- mapM dsLExprNoLP xs let unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] @@ -404,10 +460,10 @@ dsExpr (ArithSeq expr witness seq) ; dsSyntaxExpr fl [newArithSeq] } dsExpr (PArrSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, to] dsExpr (PArrSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn, to] dsExpr (PArrSeq _ _) = panic "DsExpr.dsExpr: Infinite parallel array!" @@ -426,7 +482,7 @@ See Note [Grand plan for static forms] in StaticPtrTable for an overview. -} dsExpr (HsStatic _ expr@(L loc _)) = do - expr_ds <- dsLExpr expr + expr_ds <- dsLExprNoLP expr let ty = exprType expr_ds makeStaticId <- dsLookupGlobalId makeStaticName @@ -478,7 +534,7 @@ dsExpr (RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds mk_arg (arg_ty, fl) = case findField (rec_flds rbinds) (flSelector fl) of (rhs:rhss) -> ASSERT( null rhss ) - dsLExpr rhs + dsLExprNoLP rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty @@ -592,10 +648,8 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields field_labels arg_ids mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - -- SAFE: the typechecker will complain if the synonym is - -- not bidirectional - wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con) - inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id)) + + inst_con = noLoc $ HsWrap wrap (HsConLikeOut con) -- Reconstruct with the WrapId so that unpacking happens -- The order here is because of the order in `TcPatSyn`. wrap = mkWpEvVarApps theta_vars <.> @@ -702,7 +756,10 @@ dsSyntaxExpr (SyntaxExpr { syn_expr = expr ; core_arg_wraps <- mapM dsHsWrapper arg_wraps ; core_res_wrap <- dsHsWrapper res_wrap ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs + ; zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ] ; return (core_res_wrap (mkApps fun wrapped_args)) } + where + mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr) findField :: [LHsRecField Id arg] -> Name -> [arg] findField rbinds sel @@ -774,7 +831,7 @@ dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -- See Note [Desugaring explicit lists] dsExplicitList elt_ty Nothing xs = do { dflags <- getDynFlags - ; xs' <- mapM dsLExpr xs + ; xs' <- mapM dsLExprNoLP xs ; if length xs' > maxBuildLength -- Don't generate builds if the list is very long. || length xs' == 0 @@ -795,23 +852,23 @@ dsExplicitList elt_ty (Just fln) xs dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr dsArithSeq expr (From from) - = App <$> dsExpr expr <*> dsLExpr from + = App <$> dsExpr expr <*> dsLExprNoLP from dsArithSeq expr (FromTo from to) = do dflags <- getDynFlags warnAboutEmptyEnumerations dflags from Nothing to expr' <- dsExpr expr - from' <- dsLExpr from - to' <- dsLExpr to + from' <- dsLExprNoLP from + to' <- dsLExprNoLP to return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] + = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn] dsArithSeq expr (FromThenTo from thn to) = do dflags <- getDynFlags warnAboutEmptyEnumerations dflags from (Just thn) to expr' <- dsExpr expr - from' <- dsLExpr from - thn' <- dsLExpr thn - to' <- dsLExpr to + from' <- dsLExprNoLP from + thn' <- dsLExprNoLP thn + to' <- dsLExprNoLP to return $ mkApps expr' [from', thn', to'] {- @@ -837,7 +894,7 @@ dsDo stmts ; rest <- goL stmts ; dsSyntaxExpr then_expr [rhs2, rest] } - go _ (LetStmt (L _ binds)) stmts + go _ (LetStmt binds) stmts = do { rest <- goL stmts ; dsLocalBinds binds rest } @@ -935,6 +992,22 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ {- ************************************************************************ * * + Desugaring ConLikes +* * +************************************************************************ +-} + +dsConLike :: ConLike -> CoreExpr +dsConLike (RealDataCon dc) = Var (dataConWrapId dc) +dsConLike (PatSynCon ps) = case patSynBuilder ps of + Just (id, add_void) + | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) + | otherwise -> Var id + _ -> pprPanic "dsConLike" (ppr ps) + +{- +************************************************************************ +* * \subsection{Errors and contexts} * * ************************************************************************ diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot index cc8b7ea988..864df833a7 100644 --- a/compiler/deSugar/DsExpr.hs-boot +++ b/compiler/deSugar/DsExpr.hs-boot @@ -1,10 +1,10 @@ module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr ) +import HsSyn ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr ) import Var ( Id ) import DsMonad ( DsM ) import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr -dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsLExpr, dsLExprNoLP :: LHsExpr Id -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr -dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds :: LHsLocalBinds Id -> CoreExpr -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index dc084ee233..9998a4d419 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -200,7 +200,7 @@ dsFCall fn_id co fcall mDeclHeader = do (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty (arg_tys, io_res_ty) = tcSplitFunTys rho - args <- newSysLocalsDs arg_tys + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) let @@ -300,7 +300,7 @@ dsPrimCall fn_id co fcall = do (tvs, fun_ty) = tcSplitForAllTys ty (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - args <- newSysLocalsDs arg_tys + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism ccall_uniq <- newUnique dflags <- getDynFlags @@ -724,8 +724,7 @@ toCType = f False typeTyCon :: Type -> TyCon typeTyCon ty - | UnaryRep rep_ty <- repType ty - , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) = tc | otherwise = pprPanic "DsForeign.typeTyCon" (ppr ty) @@ -784,7 +783,7 @@ getPrimTyOf ty prim_ty _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) where - UnaryRep rep_ty = repType ty + rep_ty = unwrapType ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, @@ -793,7 +792,7 @@ primTyDescChar :: DynFlags -> Type -> Char primTyDescChar dflags ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep (getPrimTyOf ty) of + = case typePrimRep1 (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int64Rep -> 'L' diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 0c34bc238d..0a66bd0bb8 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon -> GRHSs Id (LHsExpr Id) -- Guarded RHSs -> Type -- Type of RHS -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss (L _ binds)) rhs_ty +dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = ASSERT( notNull grhss ) do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss ; let match_result1 = foldr1 combineMatchResults match_results @@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do +matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result @@ -138,6 +138,7 @@ isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon +isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return isTrueLHsExpr (L _ (HsTick tickish e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 45320ccd5d..2bb303ec98 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -12,7 +12,7 @@ module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr ) import HsSyn import TcHsSyn @@ -81,10 +81,10 @@ dsListComp lquals res_ty = do dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type) dsInnerListComp (ParStmtBlock stmts bndrs _) = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs + list_ty = mkListTy bndrs_tuple_type -- really use original bndrs below! - ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) - (mkListTy bndrs_tuple_type) + ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty ; return (expr, bndrs_tuple_type) } @@ -135,6 +135,9 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM , Var unzip_fn' , inner_list_expr' ] + dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr')) + (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using) + -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold lists rather than single values let pat = mkBigLHsVarPatTupId to_bndrs -- NB: no '! @@ -225,7 +228,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt (L _ binds) : quals) list = do +deListComp (LetStmt binds : quals) list = do core_rest <- deListComp quals list dsLocalBinds binds core_rest @@ -234,7 +237,7 @@ deListComp (stmt@(TransStmt {}) : quals) list = do deBindComp pat inner_list_expr quals list deListComp (BindStmt pat list1 _ _ _ : quals) core_list2 = do -- rule A' above - core_list1 <- dsLExpr list1 + core_list1 <- dsLExprNoLP list1 deBindComp pat core_list1 quals core_list2 deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list @@ -272,6 +275,8 @@ deBindComp pat core_list1 quals core_list2 = do let res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty + -- no levity polymorphism here, as list comprehensions don't work + -- with RebindableSyntax. NB: These are *not* monad comps. [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] -- the "fail" value ... @@ -320,7 +325,7 @@ dfListComp _ _ [] = panic "dfListComp" dfListComp c_id n_id (LastStmt body _ _ : quals) = ASSERT( null quals ) - do { core_body <- dsLExpr body + do { core_body <- dsLExprNoLP body ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard @@ -329,7 +334,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do +dfListComp c_id n_id (LetStmt binds : quals) = do -- new in 1.3, local bindings core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest @@ -361,7 +366,8 @@ dfBindComp c_id n_id (pat, core_list1) quals = do let b_ty = idType n_id -- create some new local id's - [b, x] <- newSysLocalsDs [b_ty, x_ty] + b <- newSysLocalDs b_ty + x <- newSysLocalDs x_ty -- build rest of the comprehesion core_rest <- dfListComp c_id b quals @@ -489,7 +495,7 @@ dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals -- dsPArrComp (BindStmt p e _ _ _ : qs) = do filterP <- dsDPHBuiltin filterPVar - ce <- dsLExpr e + ce <- dsLExprNoLP e let ety'ce = parrElemType ce false = Var falseDataConId true = Var trueDataConId @@ -571,12 +577,12 @@ dePArrComp (BindStmt p e _ _ _ : qs) pa cea = do -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- -dePArrComp (LetStmt (L _ ds) : qs) pa cea = do +dePArrComp (LetStmt lds@(L _ ds) : qs) pa cea = do mapP <- dsDPHBuiltin mapPVar let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea - clet <- dsLocalBinds ds (mkCoreTup (map Var xs)) + clet <- dsLocalBinds lds (mkCoreTup (map Var xs)) let'v <- newSysLocalDs (exprType clet) let projBody = mkCoreLet (NonRec let'v clet) $ mkCoreTup [Var v, Var let'v] @@ -632,7 +638,7 @@ dePArrParComp qss quals = do -- generate Core corresponding to `\p -> e' -- -deLambda :: Type -- type of the argument +deLambda :: Type -- type of the argument (not levity-polymorphic) -> LPat Id -- argument pattern -> LHsExpr Id -- body -> DsM (CoreExpr, Type) @@ -641,7 +647,7 @@ deLambda ty p e = -- generate Core for a lambda pattern match, where the body is already in Core -- -mkLambda :: Type -- type of the argument +mkLambda :: Type -- type of the argument (not levity-polymorphic) -> LPat Id -- argument pattern -> CoreExpr -- desugared body -> DsM (CoreExpr, Type) @@ -682,7 +688,7 @@ dsMcStmt (LastStmt body _ ret_op) stmts ; dsSyntaxExpr ret_op [body'] } -- [ .. | let binds, stmts ] -dsMcStmt (LetStmt (L _ binds)) stmts +dsMcStmt (LetStmt binds) stmts = do { rest <- dsMcStmts stmts ; dsLocalBinds binds rest } @@ -743,7 +749,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDs n_tup_ty' + ; n_tup_var' <- newSysLocalDsNoLP n_tup_ty' ; tup_n_var' <- newSysLocalDs tup_n_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply @@ -841,6 +847,7 @@ dsInnerMonadComp :: [ExprLStmt Id] dsInnerMonadComp stmts bndrs ret_op = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)]) + -- The `unzip` function for `GroupStmt` in a monad comprehensions -- -- unzip :: m (a,b,..) -> (m a,m b,..) @@ -855,7 +862,7 @@ dsInnerMonadComp stmts bndrs ret_op mkMcUnzipM :: TransForm -> HsExpr TcId -- fmap -> Id -- Of type n (a,b,c) - -> [Type] -- [a,b,c] + -> [Type] -- [a,b,c] (not levity-polymorphic) -> DsM CoreExpr -- Of type (n a, n b, n c) mkMcUnzipM ThenForm _ ys _ = return (Var ys) -- No unzipping to do diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index d46aeaab7a..24cca5d8b2 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -12,10 +12,11 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, initTcDsForSolver, fixDs, - foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, + foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM, Applicative(..),(<$>), - duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, + duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs, + newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, mkPrintUnqualifiedDs, @@ -36,20 +37,28 @@ module DsMonad ( -- Iterations for pm checking incrCheckPmIterDs, resetPmIterDs, - -- Warnings - DsWarning, warnDs, failWithDs, discardWarningsDs, + -- Warnings and errors + DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, + failWithDs, failDs, discardWarningsDs, + askNoErrsDs, -- Data types DsMatchContext(..), EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper, - CanItFail(..), orFail + CanItFail(..), orFail, + + -- Levity polymorphism + dsNoLevPoly, dsNoLevPolyExpr ) where import TcRnMonad import FamInstEnv import CoreSyn +import MkCore ( mkCoreTup ) +import CoreUtils ( exprType, isExprLevPoly ) import HsSyn import TcIface +import TcMType ( checkForLevPolyX, formatLevPolyErr ) import LoadIface import Finder import PrelNames @@ -312,11 +321,51 @@ And all this mysterious stuff is so we can occasionally reach out and grab one or more names. @newLocalDs@ isn't exported---exported functions are defined with it. The difference in name-strings makes it easier to read debugging output. + +Note [Levity polymorphism checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Levity Polymorphism paper +<http://cs.brynmawr.edu/~rae/papers/2017/levity/levity.pdf>, levity +polymorphism is forbidden in precisely two places: in the type of a bound +term-level argument and in the type of an argument to a function. The paper +explains it more fully, but briefly: expressions in these contexts need to be +stored in registers, and it's hard (read, impossible) to store something +that's levity polymorphic. + +We cannot check for bad levity polymorphism conveniently in the type checker, +because we can't tell, a priori, which levity metavariables will be solved. +At one point, I (Richard) thought we could check in the zonker, but it's hard +to know where precisely are the abstracted variables and the arguments. So +we check in the desugarer, the only place where we can see the Core code and +still report respectable syntax to the user. This covers the vast majority +of cases; see calls to DsMonad.dsNoLevPoly and friends. + +Levity polymorphism is also prohibited in the types of binders, and the +desugarer checks for this in GHC-generated Ids. (The zonker handles +the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP. +The newSysLocalDs variant is used in the vast majority of cases where +the binder is obviously not levity polymorphic, omitting the check. +It would be nice to ASSERT that there is no levity polymorphism here, +but we can't, because of the fixM in DsArrows. It's all OK, though: +Core Lint will catch an error here. + +However, the desugarer is the wrong place for certain checks. In particular, +the desugarer can't report a sensible error message if an HsWrapper is malformed. +After all, GHC itself produced the HsWrapper. So we store some message text +in the appropriate HsWrappers (e.g. WpFun) that we can print out in the +desugarer. + +There are a few more checks in places where Core is generated outside the +desugarer. For example, in datatype and class declarations, where levity +polymorphism is checked for during validity checking. It would be nice to +have one central place for all this, but that doesn't seem possible while +still reporting nice error messages. + -} -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Id -> Type -> DsM Id -newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id))) +newUniqueId id = mk_local (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local @@ -327,12 +376,26 @@ newPredVarDs :: PredType -> DsM Var newPredVarDs pred = newSysLocalDs pred -newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") +newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDsNoLP = mk_local (fsLit "ds") + +-- this variant should be used when the caller can be sure that the variable type +-- is not levity-polymorphic. It is necessary when the type is knot-tied because +-- of the fixM used in DsArrows. See Note [Levity polymorphism checking] +newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds") newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail") + -- the fail variable is used only in a situation where we can tell that + -- levity-polymorphism is impossible. -newSysLocalsDs :: [Type] -> DsM [Id] -newSysLocalsDs tys = mapM newSysLocalDs tys +newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id] +newSysLocalsDsNoLP = mapM newSysLocalDsNoLP +newSysLocalsDs = mapM newSysLocalDs + +mk_local :: FastString -> Type -> DsM Id +mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+> + ppr ty) -- could improve the msg with another + -- parameter indicating context + ; mkSysLocalOrCoVarM fs ty } {- We can also reach out and either set/grab location information from @@ -387,6 +450,7 @@ putSrcSpanDs (RealSrcSpan real_span) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside -- | Emit a warning for the current source location +-- NB: Warns whether or not -Wxyz is set warnDs :: WarnReason -> SDoc -> DsM () warnDs reason warn = do { env <- getGblEnv @@ -396,15 +460,50 @@ warnDs reason warn mkWarnMsg dflags loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } -failWithDs :: SDoc -> DsM a -failWithDs err +-- | Emit a warning only if the correct WarnReason is set in the DynFlags +warnIfSetDs :: WarningFlag -> SDoc -> DsM () +warnIfSetDs flag warn + = whenWOptM flag $ + warnDs (Reason flag) warn + +errDs :: SDoc -> DsM () +errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs ; dflags <- getDynFlags ; let msg = mkErrMsg dflags loc (ds_unqual env) err - ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) + ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } + +-- | Issue an error, but return the expression for (), so that we can continue +-- reporting errors. +errDsCoreExpr :: SDoc -> DsM CoreExpr +errDsCoreExpr err + = do { errDs err + ; return $ mkCoreTup [] } + +failWithDs :: SDoc -> DsM a +failWithDs err + = do { errDs err ; failM } +failDs :: DsM a +failDs = failM + +-- (askNoErrsDs m) runs m +-- If m fails, (askNoErrsDs m) fails +-- If m succeeds with result r, (askNoErrsDs m) succeeds with result (r, b), +-- where b is True iff m generated no errors +-- Regardless of success or failure, any errors generated by m are propagated +-- c.f. TcRnMonad.askNoErrs +askNoErrsDs :: DsM a -> DsM (a, Bool) +askNoErrsDs m + = do { errs_var <- newMutVar emptyMessages + ; env <- getGblEnv + ; res <- setGblEnv (env { ds_msgs = errs_var }) m + ; (warns, errs) <- readMutVar errs_var + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs)) + ; return (res, isEmptyBag errs) } + mkPrintUnqualifiedDs :: DsM PrintUnqualified mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv @@ -529,3 +628,16 @@ discardWarningsDs thing_inside ; writeTcRef (ds_msgs env) old_msgs ; return result } + +-- | Fail with an error message if the type is levity polymorphic. +dsNoLevPoly :: Type -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty + +-- | Check an expression for levity polymorphism, failing if it is +-- levity polymorphic. +dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM () +-- See Note [Levity polymorphism checking] +dsNoLevPolyExpr e doc + | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc) + | otherwise = return () diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 290c172a14..0d336adbd9 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -121,7 +121,7 @@ selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) selectMatchVar (VarPat var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] selectMatchVar (AsPat var _) = return (unLoc var) -selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) +selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) -- OK, better make up one... {- @@ -736,7 +736,7 @@ mkSelectorBinds ticks pat val_expr | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDs pat_ty + ; val_var <- newSysLocalDsNoLP pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 672157e0d7..f5c3cf5066 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -444,7 +444,18 @@ tidy1 v (AsPat (L _ var) pat) -} tidy1 v (LazyPat pat) - = do { (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + -- This is a convenient place to check for unlifted types under a lazy pattern. + -- Doing this check during type-checking is unsatisfactory because we may + -- not fully know the zonked types yet. We sure do here. + = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat) + ; unless (null unlifted_bndrs) $ + putSrcSpanDs (getLoc pat) $ + errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ + text "Unlifted variables:") + 2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id)) + unlifted_bndrs))) + + ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } @@ -705,7 +716,7 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches ; locn <- getSrcSpanDs ; new_vars <- case matches of - [] -> mapM newSysLocalDs arg_tys + [] -> mapM newSysLocalDsNoLP arg_tys (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) ; eqns_info <- mapM (mk_eqn_info new_vars) matches @@ -951,6 +962,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- we have to compare the wrappers exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' exp (HsVar i) (HsVar i') = i == i' + exp (HsConLikeOut c) (HsConLikeOut c') = c == c' -- the instance for IPName derives using the id, so this works if the -- above does exp (HsIPVar i) (HsIPVar i') = i == i' @@ -1012,7 +1024,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpFun w1 w2 _) (WpFun w1' w2' _) = wrap w1 w1' && wrap w2 w2' + wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2' wrap (WpCast co) (WpCast co') = co `eqCoercion` co' wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2 wrap (WpTyApp t) (WpTyApp t') = eqType t t' diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 73b6ec300b..4a7d1cd2b7 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -207,7 +207,7 @@ same_fields flds1 flds2 ----------------- selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id] -selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDs arg_tys +selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDsNoLP arg_tys selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps) selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2] diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index e45984df64..e35358fba5 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -20,6 +20,7 @@ import Id import Name import NameSet import DataCon +import ConLike import TysWiredIn import Outputable import Util @@ -230,6 +231,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr Id -> PmExpr hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) |