projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Merge branch 'master' of http://darcs.haskell.org/ghc
[ghc-hetmet.git]
/
compiler
/
stgSyn
/
StgLint.lhs
diff --git
a/compiler/stgSyn/StgLint.lhs
b/compiler/stgSyn/StgLint.lhs
index
f2cecf9
..
29f683f
100644
(file)
--- a/
compiler/stgSyn/StgLint.lhs
+++ b/
compiler/stgSyn/StgLint.lhs
@@
-19,8
+19,8
@@
import Maybes
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
import TypeRep
import Name ( getSrcLoc )
import ErrUtils ( Message, mkLocMessage )
import TypeRep
-import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe,
- isUnLiftedType, isTyVarTy, dropForAlls, Type
+import Type ( mkFunTys, splitFunTy_maybe, splitTyConApp_maybe,
+ isUnLiftedType, isTyVarTy, dropForAlls
)
import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons )
import Util ( zipEqual, equalLength )
)
import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons )
import Util ( zipEqual, equalLength )
@@
-200,7
+200,7
@@
lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
UbxTupAlt tc -> check_bndr tc
PolyAlt -> return ()
UbxTupAlt tc -> check_bndr tc
PolyAlt -> return ()
- MaybeT $ trace (showSDoc (ppr e)) $ do
+ MaybeT $ do
-- we only allow case of tail-call or primop.
case scrut of
StgApp _ _ -> return ()
-- we only allow case of tail-call or primop.
case scrut of
StgApp _ _ -> return ()
@@
-316,7
+316,7
@@
initL (LintM m)
if isEmptyBag errs then
Nothing
else
if isEmptyBag errs then
Nothing
else
- Just (vcat (punctuate (text "") (bagToList errs)))
+ Just (vcat (punctuate blankLine (bagToList errs)))
}
instance Monad LintM where
}
instance Monad LintM where
@@
-387,26
+387,21
@@
checkFunApp :: Type -- The function type
checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
where
checkFunApp' loc _scope errs
checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
where
checkFunApp' loc _scope errs
- = cfa res_ty expected_arg_tys arg_tys
+ = cfa fun_ty arg_tys
where
where
- (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
+ cfa fun_ty [] -- Args have run out; that's fine
+ = (Just fun_ty, errs)
- cfa res_ty expected [] -- Args have run out; that's fine
- = (Just (mkFunTys expected res_ty), errs)
+ cfa fun_ty (_:arg_tys)
+ | Just (_arg_ty, res_ty) <- splitFunTy_maybe (dropForAlls fun_ty)
+ = cfa res_ty arg_tys
- cfa res_ty [] arg_tys -- Expected arg tys ran out first;
- -- first see if res_ty is a tyvar template;
- -- otherwise, maybe res_ty is a
- -- dictionary type which is actually a function?
- | isTyVarTy res_ty
- = (Just res_ty, errs)
+ | isTyVarTy fun_ty -- Expected arg tys ran out first;
+ = (Just fun_ty, errs) -- first see if fun_ty is a tyvar template;
+ -- otherwise, maybe fun_ty is a
+ -- dictionary type which is actually a function?
| otherwise
| otherwise
- = case splitFunTys res_ty of
- ([], _) -> (Nothing, addErr errs msg loc) -- Too many args
- (new_expected, new_res) -> cfa new_res new_expected arg_tys
-
- cfa res_ty (_:expected_arg_tys) (_:arg_tys)
- = cfa res_ty expected_arg_tys arg_tys
+ = (Nothing, addErr errs msg loc) -- Too many args
\end{code}
\begin{code}
\end{code}
\begin{code}