diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/simplStg/SimplStg.hs | 11 | ||||
| -rw-r--r-- | compiler/stgSyn/StgLint.hs | 60 |
2 files changed, 44 insertions, 27 deletions
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs index 4943f525af..6c8b005d80 100644 --- a/compiler/simplStg/SimplStg.hs +++ b/compiler/simplStg/SimplStg.hs @@ -51,7 +51,8 @@ stg2stg dflags module_name binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:" (pprStgTopBindings processed_binds) - ; let un_binds = unarise us1 processed_binds + ; let un_binds = stg_linter True "Unarise" + $ unarise us1 processed_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (pprStgTopBindings un_binds) @@ -60,9 +61,9 @@ stg2stg dflags module_name binds } where - stg_linter = if gopt Opt_DoStgLinting dflags - then lintStgTopBindings - else ( \ _whodunnit binds -> binds ) + stg_linter unarised + | gopt Opt_DoStgLinting dflags = lintStgTopBindings unarised + | otherwise = \ _whodunnit binds -> binds ------------------------------------------- do_stg_pass (binds, us, ccs) to_do @@ -91,7 +92,7 @@ stg2stg dflags module_name binds = do -- report verbosely, if required dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what (vcat (map ppr binds2)) - let linted_binds = stg_linter what binds2 + let linted_binds = stg_linter False what binds2 return (linted_binds, us2, ccs) -- return: processed binds -- UniqueSupply for the next guy to use diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index baceca2333..ac25ab5f50 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -56,11 +56,12 @@ generation. Solution: don't use it! (KSW 2000-05). @lintStgTopBindings@ is the top-level interface function. -} -lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding] +lintStgTopBindings :: Bool -- ^ have we run Unarise yet? + -> String -> [StgTopBinding] -> [StgTopBinding] -lintStgTopBindings whodunnit binds +lintStgTopBindings unarised whodunnit binds = {-# SCC "StgLint" #-} - case (initL (lint_binds binds)) of + case (initL unarised (lint_binds binds)) of Nothing -> binds Just msg -> pprPanic "" (vcat [ text "*** Stg Lint ErrMsgs: in" <+> @@ -196,11 +197,16 @@ lintStgExpr (StgTick _ expr) = lintStgExpr expr lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do _ <- MaybeT $ lintStgExpr scrut + lf <- liftMaybeT getLintFlags in_scope <- MaybeT $ liftM Just $ case alts_type of AlgAlt tc -> check_bndr (tyConPrimRep tc) >> return True PrimAlt rep -> check_bndr [rep] >> return True - MultiValAlt _ -> return False -- Binder is always dead in this case + -- Case binders of unboxed tuple or unboxed sum type always dead + -- after the unariser has run. See Note [Post-unarisation invariants]. + MultiValAlt _ + | lf_unarised lf -> return False + | otherwise -> return True PolyAlt -> return True MaybeT $ addInScopeVars [bndr | in_scope] $ @@ -275,12 +281,17 @@ lintAlt scrut_ty (DataAlt con, args, rhs) = do -} newtype LintM a = LintM - { unLintM :: [LintLocInfo] -- Locations + { unLintM :: LintFlags + -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag MsgDoc -- Error messages so far -> (a, Bag MsgDoc) -- Result and error messages (if any) } +data LintFlags = LintFlags { lf_unarised :: !Bool + -- ^ have we run the unariser yet? + } + data LintLocInfo = RhsOf Id -- The variable bound | LambdaBodyOf [Id] -- The lambda-binder @@ -303,20 +314,22 @@ pp_binders bs pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -initL :: LintM a -> Maybe MsgDoc -initL (LintM m) - = case (m [] emptyVarSet emptyBag) of { (_, errs) -> +initL :: Bool -> LintM a -> Maybe MsgDoc +initL unarised (LintM m) + = case (m lf [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) } + where + lf = LintFlags unarised instance Functor LintM where fmap = liftM instance Applicative LintM where - pure a = LintM $ \_loc _scope errs -> (a, errs) + pure a = LintM $ \_lf _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -325,21 +338,21 @@ instance Monad LintM where (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \loc scope errs - -> case unLintM m loc scope errs of - (r, errs') -> unLintM (k r) loc scope errs' +thenL m k = LintM $ \lf loc scope errs + -> case unLintM m lf loc scope errs of + (r, errs') -> unLintM (k r) lf loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \loc scope errs - -> case unLintM m loc scope errs of - (_, errs') -> unLintM k loc scope errs' +thenL_ m k = LintM $ \lf loc scope errs + -> case unLintM m lf loc scope errs of + (_, errs') -> unLintM k lf loc scope errs' checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = addErrL msg addErrL :: MsgDoc -> LintM () -addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc) +addErrL msg = LintM $ \_lf loc _scope errs -> ((), addErr errs msg loc) addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addErr errs_so_far msg locs @@ -350,14 +363,17 @@ addErr errs_so_far msg locs mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \loc scope errs - -> unLintM m (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \lf loc scope errs + -> unLintM m lf (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \loc scope errs +addInScopeVars ids m = LintM $ \lf loc scope errs -> let new_set = mkVarSet ids - in unLintM m loc (scope `unionVarSet` new_set) errs + in unLintM m lf loc (scope `unionVarSet` new_set) errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \lf _loc _scope errs -> (lf, errs) {- Checking function applications: we only check that the type has the @@ -457,7 +473,7 @@ stgEqType orig_ty1 orig_ty2 -- Type variables in particular checkInScope :: Id -> LintM () -checkInScope id = LintM $ \loc scope errs +checkInScope id = LintM $ \_lf loc scope errs -> if isLocalId id && not (id `elemVarSet` scope) then ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) @@ -465,7 +481,7 @@ checkInScope id = LintM $ \loc scope errs ((), errs) checkTys :: Type -> Type -> MsgDoc -> LintM () -checkTys ty1 ty2 msg = LintM $ \loc _scope errs +checkTys ty1 ty2 msg = LintM $ \_lf loc _scope errs -> if (ty1 `stgEqType` ty2) then ((), errs) else ((), addErr errs msg loc) |