X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsSyn.lhs;h=defa5bffc7deb48a145dfea2d0ec1d2c3cb4e6e3;hb=ecdaf6bc29d23bd704df8c65442ee08032a585fc;hp=ec93e8464131aa2fdcfe36f55def1c28378baef5;hpb=85e16365444e938b4adff9d241d56df4c1fbca91;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index ec93e84..defa5bf 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -20,7 +20,8 @@ module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, hsLitType, hsLPatType, hsPatType, mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, mkVanillaTuplePat, + nlHsIntLit, mkVanillaTuplePat, + shortCutLit, hsOverLitName, mkArbitraryType, -- Put this elsewhere? @@ -40,16 +41,19 @@ import HsSyn -- oodles of it import Id import TcRnMonad +import PrelNames import Type import TcType import TcMType import TysPrim import TysWiredIn import TyCon +import DataCon import Name import Var import VarSet import VarEnv +import Literal import BasicTypes import Maybes import Unique @@ -57,6 +61,22 @@ import SrcLoc import Util import Bag import Outputable +import FastString +\end{code} + +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM \end{code} @@ -102,12 +122,47 @@ hsLitType (HsString str) = stringTy hsLitType (HsStringPrim s) = addrPrimTy hsLitType (HsInt i) = intTy hsLitType (HsIntPrim i) = intPrimTy +hsLitType (HsWordPrim w) = wordPrimTy hsLitType (HsInteger i ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy \end{code} +Overloaded literals. Here mainly becuase it uses isIntTy etc + +\begin{code} +shortCutLit :: OverLitVal -> TcType -> Maybe (HsExpr TcId) +shortCutLit (HsIntegral i) ty + | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) + | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) + | isIntegerTy ty = Just (HsLit (HsInteger i ty)) + | otherwise = shortCutLit (HsFractional (fromInteger i)) ty + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + +shortCutLit (HsFractional f) ty + | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) + | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f)) + | otherwise = Nothing + +shortCutLit (HsIsString s) ty + | isStringTy ty = Just (HsLit (HsString s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit -> HsExpr Id +mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName +\end{code} %************************************************************************ %* * @@ -313,11 +368,10 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, mapM zonk_prag prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) zonk_prag prag@(L _ (InlinePrag {})) = return prag - zonk_prag (L loc (SpecPrag expr ty ds inl)) + zonk_prag (L loc (SpecPrag expr ty inl)) = do { expr' <- zonkExpr env expr ; ty' <- zonkTcTypeToType env ty - ; let ds' = zonkIdOccs env ds - ; return (L loc (SpecPrag expr' ty' ds' inl)) } + ; return (L loc (SpecPrag expr' ty' inl)) } \end{code} %************************************************************************ @@ -548,9 +602,9 @@ zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCo co) = do { co' <- zonkTcTypeToType env co - ; return (env, WpCo co') } -zonkCoFn env (WpLam id) = do { id' <- zonkIdBndr env id +zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co + ; return (env, WpCast co') } +zonkCoFn env (WpLam id) = do { id' <- zonkDictBndr env id ; let env1 = extendZonkEnv1 env id' ; return (env1, WpLam id') } zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) @@ -570,17 +624,10 @@ zonkDo env do_or_lc = do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) -zonkOverLit env ol = - let - zonkedStuff = do ty' <- zonkTcTypeToType env (overLitType ol) - e' <- zonkExpr env (overLitExpr ol) - return (e', ty') - ru f (x, y) = return (f x y) - in - case ol of - (HsIntegral i _ _) -> ru (HsIntegral i) =<< zonkedStuff - (HsFractional r _ _) -> ru (HsFractional r) =<< zonkedStuff - (HsIsString s _ _) -> ru (HsIsString s) =<< zonkedStuff +zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) + = do { ty' <- zonkTcTypeToType env ty + ; e' <- zonkExpr env e + ; return (lit { ol_witness = e', ol_type = ty' }) } ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) @@ -647,6 +694,37 @@ zonkStmt env (ExprStmt expr then_op ty) zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (env, ExprStmt new_expr new_then new_ty) +zonkStmt env (TransformStmt (stmts, binders) usingExpr maybeByExpr) + = do { (env', stmts') <- zonkStmts env stmts + ; let binders' = zonkIdOccs env' binders + ; usingExpr' <- zonkLExpr env' usingExpr + ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr + ; return (env', TransformStmt (stmts', binders') usingExpr' maybeByExpr') } + +zonkStmt env (GroupStmt (stmts, binderMap) groupByClause) + = do { (env', stmts') <- zonkStmts env stmts + ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap + ; groupByClause' <- + case groupByClause of + GroupByNothing usingExpr -> (zonkLExpr env' usingExpr) >>= (return . GroupByNothing) + GroupBySomething eitherUsingExpr byExpr -> do + eitherUsingExpr' <- mapEitherM (zonkLExpr env') (zonkExpr env') eitherUsingExpr + byExpr' <- zonkLExpr env' byExpr + return $ GroupBySomething eitherUsingExpr' byExpr' + + ; let env'' = extendZonkEnv env' (map snd binderMap') + ; return (env'', GroupStmt (stmts', binderMap') groupByClause') } + where + mapEitherM f g x = do + case x of + Left a -> f a >>= (return . Left) + Right b -> g b >>= (return . Right) + + zonkBinderMapEntry env (oldBinder, newBinder) = do + let oldBinder' = zonkIdOcc env oldBinder + newBinder' <- zonkIdBndr env newBinder + return (oldBinder', newBinder') + zonkStmt env (LetStmt binds) = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) @@ -658,6 +736,9 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } +zonkMaybeLExpr env Nothing = return Nothing +zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) + ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) @@ -742,7 +823,7 @@ zonk_pat env (TuplePat pats boxed ty) zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args }) = ASSERT( all isImmutableTyVar (pat_tvs p) ) do { new_ty <- zonkTcTypeToType env ty - ; new_dicts <- zonkIdBndrs env dicts + ; new_dicts <- zonkDictBndrs env dicts ; let env1 = extendZonkEnv env new_dicts ; (env2, new_binds) <- zonkRecMonoBinds env1 binds ; (env', new_args) <- zonkConStuff env2 args @@ -826,7 +907,7 @@ zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) -zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs fv_lhs rhs fv_rhs) +zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) = mappM zonk_bndr vars `thenM` \ new_bndrs -> newMutVar emptyVarSet `thenM` \ unbound_tv_set -> let @@ -908,56 +989,76 @@ zonkTypeZapping ty -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = do { writeMetaTyVar tv ty; return ty } - where - ty = mkArbitraryType tv - - --- When the type checker finds a type variable with no binding, --- which means it can be instantiated with an arbitrary type, it --- usually instantiates it to Void. Eg. --- --- length [] --- ===> --- length Void (Nil Void) --- --- But in really obscure programs, the type variable might have --- a kind other than *, so we need to invent a suitably-kinded type. --- --- This commit uses --- Void for kind * --- List for kind *->* --- Tuple for kind *->...*->* --- --- which deals with most cases. (Previously, it only dealt with --- kind *.) --- --- In the other cases, it just makes up a TyCon with a suitable --- kind. If this gets into an interface file, anyone reading that --- file won't understand it. This is fixable (by making the client --- of the interface file make up a TyCon too) but it is tiresome and --- never happens, so I am leaving it - -mkArbitraryType :: TcTyVar -> Type --- Make up an arbitrary type whose kind is the same as the tyvar. --- We'll use this to instantiate the (unbound) tyvar. -mkArbitraryType tv - | liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case - | otherwise = mkTyConApp tycon [] - where - kind = tyVarKind tv - (args,res) = splitKindFunTys kind + zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv + ; writeMetaTyVar tv ty + ; return ty } + where + warn span msg = setSrcSpan span (addWarnTc msg) + + +{- Note [Strangely-kinded void TyCons] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + See Trac #959 for more examples + +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. + + length [] +===> + length Void (Nil Void) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. - tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->* - = anyPrimTyCon1 -- No tuples this size +This commit uses + Void for kind * + List for kind *->* + Tuple for kind *->...*->* - | all isLiftedTypeKind args && isLiftedTypeKind res - = tupleTyCon Boxed (length args) -- *-> ... ->*->* - -- Horrible hack to make less use of mkAnyPrimTyCon +which deals with most cases. (Previously, it only dealt with +kind *.) - | otherwise - = mkAnyPrimTyCon (getUnique tv) kind +In the other cases, it just makes up a TyCon with a suitable kind. If +this gets into an interface file, anyone reading that file won't +understand it. This is fixable (by making the client of the interface +file make up a TyCon too) but it is tiresome and never happens, so I +am leaving it. + +Meanwhile I have now fixed GHC to emit a civilized warning. + -} + +mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain + -> TcTyVar + -> TcRnIf g l Type -- Used by desugarer too +-- Make up an arbitrary type whose kind is the same as the tyvar. +-- We'll use this to instantiate the (unbound) tyvar. +-- +-- Also used by the desugarer; hence the (tiresome) parameter +-- to use when generating a warning +mkArbitraryType warn tv + | liftedTypeKind `isSubKind` kind -- The vastly common case + = return anyPrimTy + | eqKind kind (tyConKind anyPrimTyCon1) -- *->* + = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size + | all isLiftedTypeKind args -- *-> ... ->*->* + , isLiftedTypeKind res -- Horrible hack to make less use + = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon + | otherwise + = do { warn (getSrcSpan tv) msg + ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) } -- Same name as the tyvar, apart from making it start with a colon (sigh) -- I dread to think what will happen if this gets out into an -- interface file. Catastrophe likely. Major sigh. + where + kind = tyVarKind tv + (args,res) = splitKindFunTys kind + tup_tc = tupleTyCon Boxed (length args) + + msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon")) + 2 (ptext (sLit "of kind") <+> quotes (ppr kind)) + , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv)) + , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) + , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway).")) + , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] \end{code}