diff options
Diffstat (limited to 'compiler')
192 files changed, 8392 insertions, 10598 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index c2cf0bfcdd..e08bc67241 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -42,12 +42,18 @@ module DataCon ( -- * Splitting product types splitProductType_maybe, splitProductType, deepSplitProductType, - deepSplitProductType_maybe + deepSplitProductType_maybe, + + -- ** Promotion related functions + promoteType, isPromotableType, isPromotableTyCon, + buildPromotedTyCon, buildPromotedDataCon, ) where #include "HsVersions.h" import Type +import TypeRep( Type(..) ) -- Used in promoteType +import Kind import Unify import Coercion import TyCon @@ -61,6 +67,7 @@ import Util import BasicTypes import FastString import Module +import VarEnv import qualified Data.Data as Data import qualified Data.Typeable @@ -959,4 +966,86 @@ computeRep stricts tys where (_tycon, _tycon_args, arg_dc, arg_tys) = deepSplitProductType "unbox_strict_arg_ty" ty -\end{code}
\ No newline at end of file +\end{code} + + +%************************************************************************ +%* * + Promoting of data types to the kind level +%* * +%************************************************************************ + +These two 'buildPromoted..' functions are here because + * They belong together + * 'buildPromotedTyCon' is used by promoteType + * 'buildPromotedTyCon' depends on DataCon stuff + +\begin{code} +buildPromotedTyCon :: TyCon -> TyCon +buildPromotedTyCon tc + = mkPromotedTyCon tc tySuperKind + +buildPromotedDataCon :: DataCon -> TyCon +buildPromotedDataCon dc + = ASSERT ( isPromotableType ty ) + mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity + where + ty = dataConUserType dc + kind = promoteType ty + arity = dataConSourceArity dc +\end{code} + +Note [Promoting a Type to a Kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppsoe we have a data constructor D + D :: forall (a:*). Maybe a -> T a +We promote this to be a type constructor 'D: + 'D :: forall (k:BOX). 'Maybe k -> 'T k + +The transformation from type to kind is done by promoteType + + * Convert forall (a:*) to forall (k:BOX), and substitute + + * Ensure all foralls are at the top (no higher rank stuff) + + * Ensure that all type constructors mentioned (Maybe and T + in the example) are promotable; that is, they have kind + * -> ... -> * -> * + +\begin{code} +isPromotableType :: Type -> Bool +isPromotableType ty + = all (isLiftedTypeKind . tyVarKind) tvs + && go rho + where + (tvs, rho) = splitForAllTys ty + go (TyConApp tc tys) | Just n <- isPromotableTyCon tc + = tys `lengthIs` n && all go tys + go (FunTy arg res) = go arg && go res + go (TyVarTy tvar) = tvar `elem` tvs + go _ = False + +-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] +isPromotableTyCon :: TyCon -> Maybe Int +isPromotableTyCon tc + | all isLiftedTypeKind (res:args) = Just $ length args + | otherwise = Nothing + where + (args, res) = splitKindFunTys (tyConKind tc) + +-- | Promotes a type to a kind. +-- Assumes the argument satisfies 'isPromotableType' +promoteType :: Type -> Kind +promoteType ty + = mkForAllTys kvs (go rho) + where + (tvs, rho) = splitForAllTys ty + kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ] + env = zipVarEnv tvs kvs + + go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) + go (FunTy arg res) = mkArrowKind (go arg) (go res) + go (TyVarTy tv) | Just kv <- lookupVarEnv env tv + = TyVarTy kv + go _ = panic "promoteType" -- Argument did not satisfy isPromotableType +\end{code} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a40d46f8a9..60f4cf16ae 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -26,6 +26,7 @@ module MkId ( mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody, unwrapFamInstScrut, + wrapTypeFamInstBody, unwrapTypeFamInstScrut, mkUnpackCase, mkProductBox, -- And some particular Ids; see below for why they are wired in @@ -227,7 +228,7 @@ mkDataConIds wrap_name wkr_name data_con = DCIds Nothing nt_work_id | any isBanged all_strict_marks -- Algebraic, needs wrapper - || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs + || not (null eq_spec) -- NB: LoadIface.ifaceDeclImplicitBndrs || isFamInstTyCon tycon -- depends on this test = DCIds (Just alg_wrap_id) wrk_id @@ -709,12 +710,22 @@ wrapFamInstBody tycon args body | otherwise = body +-- Same as `wrapFamInstBody`, but for type family instances, which are +-- represented by a `CoAxiom`, and not a `TyCon` +wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr +wrapTypeFamInstBody axiom args body + = mkCast body (mkSymCo (mkAxInstCo axiom args)) + unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon = mkCast scrut (mkAxInstCo co_con args) | otherwise = scrut + +unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr +unwrapTypeFamInstScrut axiom args scrut + = mkCast scrut (mkAxInstCo axiom args) \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 64ca362d54..e4a9c7d82a 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -430,6 +430,9 @@ instance Outputable Name where instance OutputableBndr Name where pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + pprName :: Name -> SDoc pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 9f8f32d1b3..ff1f71dc5c 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -209,7 +209,7 @@ pprNameSpaceBrief TcClsName = ptext (sLit "tc") -- demoteNameSpace lowers the NameSpace if possible. We can not know -- in advance, since a TvName can appear in an HsTyVar. --- see Note [Demotion] +-- See Note [Demotion] in RnEnv demoteNameSpace :: NameSpace -> Maybe NameSpace demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing @@ -217,24 +217,6 @@ demoteNameSpace TvName = Nothing demoteNameSpace TcClsName = Just DataName \end{code} -Note [Demotion] -~~~~~~~~~~~~~~~ - -When the user writes: - data Nat = Zero | Succ Nat - foo :: f Zero -> Int - -'Zero' in the type signature of 'foo' is parsed as: - HsTyVar ("Zero", TcClsName) - -When the renamer hits this occurence of 'Zero' it's going to realise -that it's not in scope. But because it is renaming a type, it knows -that 'Zero' might be a promoted data constructor, so it will demote -its namespace to DataName and do a second lookup. - -The final result (after the renamer) will be: - HsTyVar ("Zero", DataName) - %************************************************************************ %* * @@ -371,7 +353,7 @@ sequentially starting at 0. So we can make a Unique using mkUnique ns key :: Unique -where 'ns' is a Char reprsenting the name space. This in turn makes it +where 'ns' is a Char representing the name space. This in turn makes it easy to build an OccEnv. \begin{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 0353e65d04..de0ff56222 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -273,6 +273,9 @@ instance OutputableBndr RdrName where | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n | otherwise = ppr n + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + showRdrName :: RdrName -> String showRdrName r = showSDoc (ppr r) @@ -503,6 +506,7 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- ^ Take a list of GREs which have the right OccName -- Pick those GREs that are suitable for this RdrName -- And for those, keep only only the Provenances that are suitable +-- Only used for Qual and Unqual, not Orig or Exact -- -- Consider: -- @@ -519,7 +523,8 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- the locally-defined @f@, and a GRE for the imported @f@, with a /single/ -- provenance, namely the one for @Baz(f)@. pickGREs rdr_name gres - = mapCatMaybes pick gres + = ASSERT2( isSrcRdrName rdr_name, ppr rdr_name ) + mapCatMaybes pick gres where rdr_is_unqual = isUnqual rdr_name rdr_is_qual = isQual_maybe rdr_name diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index d7caf2a521..ea8e9d2622 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -85,7 +85,7 @@ import FastTypes import FastString import Outputable -import StaticFlags ( opt_SuppressVarKinds ) +-- import StaticFlags ( opt_SuppressVarKinds ) import Data.Data \end{code} @@ -211,9 +211,11 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds \begin{code} instance Outputable Var where - ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) - <+> if (not opt_SuppressVarKinds) then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")") - else empty + ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) +-- Printing the type on every occurrence is too much! +-- <+> if (not opt_SuppressVarKinds) +-- then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")") +-- else empty ppr_debug :: Var -> SDoc ppr_debug (TyVar {}) = ptext (sLit "tv") diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 20795f7c82..de542fbe1b 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -105,8 +105,10 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] CmmSwitch arg ids -> [Old.CmmSwitch arg ids] - CmmCall e _ _ _ _ -> [Old.CmmJump e []] + -- ToDo: STG Live + CmmCall e _ _ _ _ -> [Old.CmmJump e Nothing] CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of Old.BasicBlock _ stmts -> stmts where Just block = mapLookup bid $ toBlockMap g + diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 225f2f1cce..fea23e6632 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -169,31 +169,6 @@ lintCmmLast labels node = case node of text "switch scrutinee is not a word: " <> pprPlatform platform e <> text " :: " <> ppr erep) - - CmmCall { cml_target = target, cml_cont = cont } -> do - _ <- lintCmmExpr target - maybe (return ()) checkTarget cont - - CmmForeignCall tgt _ args succ _ _ -> do - lintTarget tgt - mapM_ lintCmmExpr args - checkTarget succ - where - checkTarget id - | setMember id labels = return () - | otherwise = cmmLintErr (\_ -> text "Branch to nonexistent id" <+> ppr id) - - -lintTarget :: ForeignTarget -> CmmLint () -lintTarget (ForeignTarget e _) = lintCmmExpr e >> return () -lintTarget (PrimTarget {}) = return () - - -checkCond :: CmmExpr -> CmmLint () -checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond expr - = cmmLintErr (\platform -> hang (text "expression is not a conditional:") 2 (pprPlatform platform expr)) -- ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 007b7a715e..ae715a9eb7 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -65,8 +65,8 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmBranch b) = b:m stmt m (CmmCondBranch e b) = b:(expr m e) stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e - stmt m (CmmJump e as) = expr (actuals m as) e - stmt m (CmmReturn as) = actuals m as + stmt m (CmmJump e _) = expr m e + stmt m (CmmReturn) = m actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as -- We have to do a deep fold into CmmExpr because -- there may be a BlockId in the CmmBlock literal. @@ -273,7 +273,7 @@ inlineStmt u a (CmmCall target regs es ret) es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d +inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live inlineStmt _ _ other_stmt = other_stmt inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index f3ac1ed1e7..5dab1dd68b 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -21,7 +21,7 @@ module CmmParse ( parseCmmFile ) where -import CgMonad hiding (getDynFlags) +import CgMonad import CgExtCode import CgHeapery import CgUtils @@ -407,10 +407,10 @@ stmt :: { ExtCode } { do as <- sequence $5; doSwitch $2 $3 as $6 } | 'goto' NAME ';' { do l <- lookupLabel $2; stmtEC (CmmBranch l) } - | 'jump' expr maybe_actuals ';' - { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) } - | 'return' maybe_actuals ';' - { do e <- sequence $2; stmtEC (CmmReturn e) } + | 'jump' expr vols ';' + { do e <- $2; stmtEC (CmmJump e $3) } + | 'return' ';' + { stmtEC CmmReturn } | 'if' bool_expr 'goto' NAME { do l <- lookupLabel $4; cmmRawIf $2 l } | 'if' bool_expr '{' body '}' else @@ -925,13 +925,12 @@ doStore rep addr_code val_code emitRetUT :: [(CgRep,CmmExpr)] -> Code emitRetUT args = do tickyUnboxedTupleReturn (length args) -- TICK - (sp, stmts) <- pushUnboxedTuple 0 args + (sp, stmts, live) <- pushUnboxedTuple 0 args emitSimultaneously stmts -- NB. the args might overlap with the stack slots -- or regs that we assign to, so better use -- simultaneous assignments here (#3546) when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) []) - -- TODO (when using CPS): emitStmt (CmmReturn (map snd args)) + stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index b9d1b9d1a4..e314ec1a45 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -6,42 +6,39 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module OldCmm ( CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl, ListGraph(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..), CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual, + cmmMapGraph, cmmTopMapGraph, + GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, + CmmStmt(..), CmmReturnInfo(..), CmmHinted(..), HintedCmmFormal, HintedCmmActual, + CmmSafety(..), CmmCallTarget(..), - New.GenCmmDecl(..), - New.ForeignHint(..), + New.GenCmmDecl(..), New.ForeignHint(..), + module CmmExpr, - Section(..), - ProfilingInfo(..), C_SRT(..) - ) where + + Section(..), ProfilingInfo(..), C_SRT(..) + ) where #include "HsVersions.h" import qualified Cmm as New -import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..), - CmmFormal, CmmActual, Section(..), CmmStatic(..), - ProfilingInfo(..), ClosureTypeInfo(..) ) +import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..), + CmmFormal, CmmActual, Section(..), CmmStatic(..), + ProfilingInfo(..), ClosureTypeInfo(..) ) import BlockId -import CmmExpr -import ForeignCall import ClosureInfo +import CmmExpr import FastString +import ForeignCall -- A [[BlockId]] is a local label. @@ -55,10 +52,10 @@ import FastString -- | A frame that is to be pushed before entry to the function. -- Used to handle 'update' frames. -data UpdateFrame = - UpdateFrame - CmmExpr -- Frame header. Behaves like the target of a 'jump'. - [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'. +data UpdateFrame + = UpdateFrame + CmmExpr -- Frame header. Behaves like the target of a 'jump'. + [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'. ----------------------------------------------------------------------------- -- Cmm, CmmDecl, CmmBasicBlock @@ -68,14 +65,15 @@ data UpdateFrame = -- re-orderd during code generation. -- | A control-flow graph represented as a list of extended basic blocks. +-- +-- Code, may be empty. The first block is the entry point. The +-- order is otherwise initially unimportant, but at some point the +-- code gen will fix the order. +-- +-- BlockIds must be unique across an entire compilation unit, since +-- they are translated to assembly-language labels, which scope +-- across a whole compilation unit. newtype ListGraph i = ListGraph [GenBasicBlock i] - -- ^ Code, may be empty. The first block is the entry point. The - -- order is otherwise initially unimportant, but at some point the - -- code gen will fix the order. - - -- BlockIds must be unique across an entire compilation unit, since - -- they are translated to assembly-language labels, which scope - -- across a whole compilation unit. -- | Cmm with the info table as a data type type CmmGroup = GenCmmGroup CmmStatics CmmInfoTable (ListGraph CmmStmt) @@ -101,84 +99,104 @@ type CmmBasicBlock = GenBasicBlock CmmStmt instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l -blockId :: GenBasicBlock i -> BlockId --- The branch block id is that of the first block in +-- | The branch block id is that of the first block in -- the branch, which is that branch's entry point +blockId :: GenBasicBlock i -> BlockId blockId (BasicBlock blk_id _ ) = blk_id blockStmts :: GenBasicBlock i -> [i] blockStmts (BasicBlock _ stmts) = stmts - mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i' mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) + ---------------------------------------------------------------- -- graph maps ---------------------------------------------------------------- cmmMapGraph :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g' -cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' - cmmMapGraph f tops = map (cmmTopMapGraph f) tops + +cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g' cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) cmmTopMapGraph _ (CmmData s ds) = CmmData s ds -data CmmReturnInfo = CmmMayReturn - | CmmNeverReturns - deriving ( Eq ) +data CmmReturnInfo + = CmmMayReturn + | CmmNeverReturns + deriving ( Eq ) ----------------------------------------------------------------------------- --- CmmStmt +-- CmmStmt -- A "statement". Note that all branches are explicit: there are no -- control transfers to computed addresses, except when transfering -- control to a new function. ----------------------------------------------------------------------------- -data CmmStmt -- Old-style +data CmmStmt = CmmNop | CmmComment FastString - | CmmAssign CmmReg CmmExpr -- Assign to register + | CmmAssign CmmReg CmmExpr -- Assign to register - | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. + | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. - | CmmCall -- A call (foreign, native or primitive), with - CmmCallTarget - [HintedCmmFormal] -- zero or more results - [HintedCmmActual] -- zero or more arguments - CmmReturnInfo - -- Some care is necessary when handling the arguments of these, see - -- [Register parameter passing] and the hack in cmm/CmmOpt.hs + | CmmCall -- A call (foreign, native or primitive), with + CmmCallTarget + [HintedCmmFormal] -- zero or more results + [HintedCmmActual] -- zero or more arguments + CmmReturnInfo + -- Some care is necessary when handling the arguments of these, see + -- [Register parameter passing] and the hack in cmm/CmmOpt.hs | CmmBranch BlockId -- branch to another BB in this fn | CmmCondBranch CmmExpr BlockId -- conditional branch - | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch - -- The scrutinee is zero-based; - -- zero -> first block - -- one -> second block etc - -- Undefined outside range, and when there's a Nothing - - | CmmJump CmmExpr -- Jump to another C-- function, - [HintedCmmActual] -- with these parameters. (parameters never used) - - | CmmReturn -- Return from a native C-- function, - [HintedCmmActual] -- with these return values. (parameters never used) - -data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: New.ForeignHint } - deriving( Eq ) - -type HintedCmmFormal = CmmHinted CmmFormal -type HintedCmmActual = CmmHinted CmmActual - -data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible + | CmmSwitch -- Table branch + CmmExpr -- The scrutinee is zero-based; + [Maybe BlockId] -- zero -> first block + -- one -> second block etc + -- Undefined outside range, and when + -- there's a Nothing + + | CmmJump -- Jump to another C-- function, + CmmExpr -- Target + (Maybe [GlobalReg]) -- Live registers at call site; + -- Nothing -> no information, assume + -- all live + -- Just .. -> info on liveness, [] + -- means no live registers + -- This isn't all 'live' registers, just + -- the argument STG registers that are live + -- AND also possibly mapped to machine + -- registers. (So Sp, Hp, HpLim... ect + -- are never included here as they are + -- always live, only R2.., D1.. are + -- on this list) + + | CmmReturn -- Return from a native C-- function, + +data CmmHinted a + = CmmHinted { + hintlessCmm :: a, + cmmHint :: New.ForeignHint + } + deriving( Eq ) + +type HintedCmmFormal = CmmHinted CmmFormal +type HintedCmmActual = CmmHinted CmmActual + +data CmmSafety + = CmmUnsafe + | CmmSafe C_SRT + | CmmInterruptible -- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' instance UserOfLocalRegs CmmStmt where foldRegsUsed f (set::b) s = stmt s set - where + where stmt :: CmmStmt -> b -> b stmt (CmmNop) = id stmt (CmmComment {}) = id @@ -188,8 +206,8 @@ instance UserOfLocalRegs CmmStmt where stmt (CmmBranch _) = id stmt (CmmCondBranch e _) = gen e stmt (CmmSwitch e _) = gen e - stmt (CmmJump e es) = gen e . gen es - stmt (CmmReturn es) = gen es + stmt (CmmJump e _) = gen e + stmt (CmmReturn) = id gen :: UserOfLocalRegs a => a -> b -> b gen a set = foldRegsUsed f set a @@ -203,13 +221,13 @@ instance UserOfSlots CmmCallTarget where foldSlotsUsed _ set (CmmPrim {}) = set instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where - foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) + foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) instance UserOfSlots a => UserOfSlots (CmmHinted a) where - foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a) + foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a) instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where - foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) + foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) {- Discussion @@ -225,7 +243,7 @@ conditional jump are explicit. ---NR] One possible way to fix this would be: -data CmmStat = +data CmmStat = ... | CmmJump CmmBranchDest | CmmCondJump CmmExpr CmmBranchDest @@ -252,18 +270,19 @@ So we'll stick with the way it is, and add the optimisation to the NCG. -} ----------------------------------------------------------------------------- --- CmmCallTarget +-- CmmCallTarget -- -- The target of a CmmCall. ----------------------------------------------------------------------------- data CmmCallTarget - = CmmCallee -- Call a function (foreign or native) - CmmExpr -- literal label <=> static call - -- other expression <=> dynamic call - CCallConv -- The calling convention - - | CmmPrim -- Call a "primitive" (eg. sin, cos) - CallishMachOp -- These might be implemented as inline - -- code by the backend. + = CmmCallee -- Call a function (foreign or native) + CmmExpr -- literal label <=> static call + -- other expression <=> dynamic call + CCallConv -- The calling convention + + | CmmPrim -- Call a "primitive" (eg. sin, cos) + CallishMachOp -- These might be implemented as inline + -- code by the backend. deriving Eq + diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 6a8fab48e8..d0fd0cb3e4 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -32,12 +32,11 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -module OldPprCmm - ( pprStmt - , module PprCmmDecl - , module PprCmmExpr - ) -where +module OldPprCmm ( + pprStmt, + module PprCmmDecl, + module PprCmmExpr + ) where import BlockId import CLabel @@ -46,7 +45,6 @@ import OldCmm import PprCmmDecl import PprCmmExpr - import BasicTypes import ForeignCall import Outputable @@ -90,7 +88,7 @@ pprStmt platform stmt = case stmt of -- ; CmmNop -> semi - -- // text + -- // text CmmComment s -> text "//" <+> ftext s -- reg = expr; @@ -134,8 +132,8 @@ pprStmt platform stmt = case stmt of CmmBranch ident -> genBranch ident CmmCondBranch expr ident -> genCondBranch platform expr ident - CmmJump expr params -> genJump platform expr params - CmmReturn params -> genReturn platform params + CmmJump expr live -> genJump platform expr live + CmmReturn -> genReturn platform CmmSwitch arg ids -> genSwitch platform arg ids -- Just look like a tuple, since it was a tuple before @@ -157,7 +155,6 @@ pprUpdateFrame platform (UpdateFrame expr args) = , space , parens ( commafy $ map (pprPlatform platform) args ) ] - -- -------------------------------------------------------------------------- -- goto local label. [1], section 6.6 -- @@ -184,31 +181,26 @@ genCondBranch platform expr ident = -- -- jump foo(a, b, c); -- -genJump :: Platform -> CmmExpr -> [CmmHinted CmmExpr] -> SDoc -genJump platform expr args = +genJump :: Platform -> CmmExpr -> Maybe [GlobalReg] -> SDoc +genJump platform expr live = hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr then pprExpr platform expr else case expr of CmmLoad (CmmReg _) _ -> pprExpr platform expr - _ -> parens (pprExpr platform expr) - , space - , parens ( commafy $ map (pprPlatform platform) args ) - , semi ] - + _ -> parens (pprExpr platform expr) + , semi <+> ptext (sLit "// ") + , maybe empty ppr live] -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- -- return (a, b, c); -- -genReturn :: Platform -> [CmmHinted CmmExpr] -> SDoc -genReturn platform args = - hcat [ ptext (sLit "return") - , space - , parens ( commafy $ map (pprPlatform platform) args ) - , semi ] +genReturn :: Platform -> SDoc +genReturn _ = + hcat [ ptext (sLit "return") , semi ] -- -------------------------------------------------------------------------- -- Tabled jump to local label @@ -250,3 +242,4 @@ genSwitch platform expr maybe_ids commafy :: [SDoc] -> SDoc commafy xs = fsep $ punctuate comma xs + diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index d2a95b6599..658e3ca5d8 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -172,7 +172,7 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") pprStmt :: Platform -> CmmStmt -> SDoc pprStmt platform stmt = case stmt of - CmmReturn _ -> panic "pprStmt: return statement should have been cps'd away" + CmmReturn -> panic "pprStmt: return statement should have been cps'd away" CmmNop -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it @@ -248,7 +248,7 @@ pprStmt platform stmt = case stmt of CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch platform expr ident - CmmJump lbl _params -> mkJMP_(pprExpr platform lbl) <> semi + CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi CmmSwitch arg ids -> pprSwitch platform arg ids pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc @@ -757,12 +757,14 @@ isStrangeTypeReg (CmmLocal _) = False isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g isStrangeTypeGlobal :: GlobalReg -> Bool +isStrangeTypeGlobal CCCS = True isStrangeTypeGlobal CurrentTSO = True isStrangeTypeGlobal CurrentNursery = True isStrangeTypeGlobal BaseReg = True isStrangeTypeGlobal r = isFixedPtrGlobalReg r strangeRegType :: CmmReg -> Maybe SDoc +strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *")) strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *")) strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *")) strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *")) @@ -793,6 +795,7 @@ pprGlobalReg gr = case gr of SpLim -> ptext (sLit "SpLim") Hp -> ptext (sLit "Hp") HpLim -> ptext (sLit "HpLim") + CCCS -> ptext (sLit "CCCS") CurrentTSO -> ptext (sLit "CurrentTSO") CurrentNursery -> ptext (sLit "CurrentNursery") HpAlloc -> ptext (sLit "HpAlloc") diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 65f8a52981..198e192f5c 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -5,37 +5,31 @@ \section[CgBindery]{Utility functions related to doing @CgBindings@} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module CgBindery ( - CgBindings, CgIdInfo, - StableLoc, VolatileLoc, + CgBindings, CgIdInfo, + StableLoc, VolatileLoc, - cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, + cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF, - stableIdInfo, heapIdInfo, + stableIdInfo, heapIdInfo, taggedStableIdInfo, taggedHeapIdInfo, - letNoEscapeIdInfo, idInfoToAmode, + letNoEscapeIdInfo, idInfoToAmode, - addBindC, addBindsC, + addBindC, addBindsC, - nukeVolatileBinds, - nukeDeadBindings, - getLiveStackSlots, + nukeVolatileBinds, + nukeDeadBindings, + getLiveStackSlots, getLiveStackBindings, - bindArgsToStack, rebindToStack, - bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs, - bindNewToTemp, - getArgAmode, getArgAmodes, - getCgIdInfo, - getCAddrModeIfVolatile, getVolatileRegs, - maybeLetNoEscape, + bindArgsToStack, rebindToStack, + bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs, + bindNewToTemp, + getArgAmode, getArgAmodes, + getCgIdInfo, + getCAddrModeIfVolatile, getVolatileRegs, + maybeLetNoEscape, ) where import CgMonad @@ -47,7 +41,7 @@ import ClosureInfo import Constants import OldCmm -import PprCmm ( {- instance Outputable -} ) +import PprCmm ( {- instance Outputable -} ) import SMRep import Id import DataCon @@ -64,40 +58,39 @@ import FastString \end{code} - %************************************************************************ -%* * +%* * \subsection[Bindery-datatypes]{Data types} -%* * +%* * %************************************************************************ @(CgBinding a b)@ is a type of finite maps from a to b. The assumption used to be that @lookupCgBind@ must get exactly one -match. This is {\em completely wrong} in the case of compiling -letrecs (where knot-tying is used). An initial binding is fed in (and +match. This is {\em completely wrong} in the case of compiling +letrecs (where knot-tying is used). An initial binding is fed in (and never evaluated); eventually, a correct binding is put into the -environment. So there can be two bindings for a given name. +environment. So there can be two bindings for a given name. \begin{code} type CgBindings = IdEnv CgIdInfo data CgIdInfo - = CgIdInfo - { cg_id :: Id -- Id that this is the info for - -- Can differ from the Id at occurrence sites by - -- virtue of being externalised, for splittable C - , cg_rep :: CgRep - , cg_vol :: VolatileLoc - , cg_stb :: StableLoc - , cg_lf :: LambdaFormInfo + = CgIdInfo + { cg_id :: Id -- Id that this is the info for + -- Can differ from the Id at occurrence sites by + -- virtue of being externalised, for splittable C + , cg_rep :: CgRep + , cg_vol :: VolatileLoc + , cg_stb :: StableLoc + , cg_lf :: LambdaFormInfo , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode } mkCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo mkCgIdInfo id vol stb lf = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } where tag | Just con <- isDataConWorkId_maybe id, @@ -114,16 +107,16 @@ mkCgIdInfo id vol stb lf voidIdInfo :: Id -> CgIdInfo voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc - , cg_stb = VoidLoc, cg_lf = mkLFArgument id - , cg_rep = VoidArg, cg_tag = 0 } - -- Used just for VoidRep things + , cg_stb = VoidLoc, cg_lf = mkLFArgument id + , cg_rep = VoidArg, cg_tag = 0 } + -- Used just for VoidRep things -data VolatileLoc -- These locations die across a call +data VolatileLoc -- These locations die across a call = NoVolatileLoc - | RegLoc CmmReg -- In one of the registers (global or local) - | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure) - | VirNodeLoc ByteOff -- Cts of offset indirect from Node - -- ie *(Node+offset). + | RegLoc CmmReg -- In one of the registers (global or local) + | VirHpLoc VirtualHpOffset -- Hp+offset (address of closure) + | VirNodeLoc ByteOff -- Cts of offset indirect from Node + -- ie *(Node+offset). -- NB. Byte offset, because we subtract R1's -- tag from the offset. @@ -131,7 +124,7 @@ mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon -> CgIdInfo mkTaggedCgIdInfo id vol stb lf con = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con } \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -141,20 +134,18 @@ the @CgBindings@ environment in @CgBindery@. data StableLoc = NoStableLoc - | VirStkLoc VirtualSpOffset -- The thing is held in this - -- stack slot + | VirStkLoc VirtualSpOffset -- The thing is held in this + -- stack slot - | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the - -- value is this stack pointer - -- (as opposed to the contents of the slot) + | VirStkLNE VirtualSpOffset -- A let-no-escape thing; the + -- value is this stack pointer + -- (as opposed to the contents of the slot) - | StableLoc CmmExpr - | VoidLoc -- Used only for VoidRep variables. They never need to - -- be saved, so it makes sense to treat treat them as - -- having a stable location -\end{code} + | StableLoc CmmExpr + | VoidLoc -- Used only for VoidRep variables. They never need to + -- be saved, so it makes sense to treat treat them as + -- having a stable location -\begin{code} instance PlatformOutputable CgIdInfo where pprPlatform platform (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info @@ -175,9 +166,9 @@ instance PlatformOutputable StableLoc where \end{code} %************************************************************************ -%* * +%* * \subsection[Bindery-idInfo]{Manipulating IdInfo} -%* * +%* * %************************************************************************ \begin{code} @@ -191,7 +182,7 @@ letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info +stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info @@ -216,7 +207,7 @@ untagNodeIdInfo id offset lf_info tag idInfoToAmode :: CgIdInfo -> FCode CmmExpr idInfoToAmode info = case cg_vol info of { - RegLoc reg -> returnFC (CmmReg reg) ; + RegLoc reg -> returnFC (CmmReg reg) ; VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off) mach_rep) ; VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off @@ -226,14 +217,14 @@ idInfoToAmode info case cg_stb info of StableLoc amode -> returnFC $! maybeTag amode VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off - ; return (CmmLoad sp_rel mach_rep) } + ; return (CmmLoad sp_rel mach_rep) } VirStkLNE sp_off -> getSpRelOffset sp_off VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info)) - -- We return a 'bottom' amode, rather than panicing now - -- In this way getArgAmode returns a pair of (VoidArg, bottom) - -- and that's exactly what we want + -- We return a 'bottom' amode, rather than panicing now + -- In this way getArgAmode returns a pair of (VoidArg, bottom) + -- and that's exactly what we want NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info)) } @@ -256,16 +247,16 @@ cgIdInfoArgRep = cg_rep maybeLetNoEscape :: CgIdInfo -> Maybe VirtualSpOffset maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off -maybeLetNoEscape _ = Nothing +maybeLetNoEscape _ = Nothing \end{code} %************************************************************************ -%* * +%* * \subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@} -%* * +%* * %************************************************************************ -.There are three basic routines, for adding (@addBindC@), modifying +There are three basic routines, for adding (@addBindC@), modifying (@modifyBindC@) and looking up (@getCgIdInfo@) bindings. A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. @@ -274,72 +265,72 @@ The name should not already be bound. (nice ASSERT, eh?) \begin{code} addBindC :: Id -> CgIdInfo -> Code addBindC name stuff_to_bind = do - binds <- getBinds - setBinds $ extendVarEnv binds name stuff_to_bind + binds <- getBinds + setBinds $ extendVarEnv binds name stuff_to_bind addBindsC :: [(Id, CgIdInfo)] -> Code addBindsC new_bindings = do - binds <- getBinds - let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) - binds - new_bindings - setBinds new_binds + binds <- getBinds + let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) + binds + new_bindings + setBinds new_binds modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code modifyBindC name mangle_fn = do - binds <- getBinds - setBinds $ modifyVarEnv mangle_fn binds name + binds <- getBinds + setBinds $ modifyVarEnv mangle_fn binds name getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first - ; local_binds <- getBinds - ; case lookupVarEnv local_binds id of { - Just info -> return info ; - Nothing -> do - - { -- Try top-level bindings - static_binds <- getStaticBinds - ; case lookupVarEnv static_binds id of { - Just info -> return info ; - Nothing -> - - -- Should be imported; make up a CgIdInfo for it - let - name = idName id - in - if isExternalName name then do - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) - return (stableIdInfo id ext_lbl (mkLFImported id)) - else - if isVoidArg (idCgRep id) then - -- Void things are never in the environment - return (voidIdInfo id) - else - -- Bug - cgLookupPanic id - }}}} + = do { -- Try local bindings first + ; local_binds <- getBinds + ; case lookupVarEnv local_binds id of { + Just info -> return info ; + Nothing -> do + + { -- Try top-level bindings + static_binds <- getStaticBinds + ; case lookupVarEnv static_binds id of { + Just info -> return info ; + Nothing -> + + -- Should be imported; make up a CgIdInfo for it + let + name = idName id + in + if isExternalName name then do + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) + return (stableIdInfo id ext_lbl (mkLFImported id)) + else + if isVoidArg (idCgRep id) then + -- Void things are never in the environment + return (voidIdInfo id) + else + -- Bug + cgLookupPanic id + }}}} - + cgLookupPanic :: Id -> FCode a cgLookupPanic id - = do static_binds <- getStaticBinds - local_binds <- getBinds + = do static_binds <- getStaticBinds + local_binds <- getBinds -- srt <- getSRTLabel pprPanic "cgLookupPanic (probably invalid Core; try -dcore-lint)" - (vcat [ppr id, - ptext (sLit "static binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], - ptext (sLit "local binds for:"), + (vcat [ppr id, + ptext (sLit "static binds for:"), + vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], + ptext (sLit "local binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] -- ptext (sLit "SRT label") <+> pprCLabel srt - ]) + ]) \end{code} %************************************************************************ -%* * +%* * \subsection[Bindery-nuke-volatile]{Nuking volatile bindings} -%* * +%* * %************************************************************************ We sometimes want to nuke all the volatile bindings; we must be sure @@ -357,71 +348,68 @@ nukeVolatileBinds binds %************************************************************************ -%* * +%* * \subsection[lookup-interface]{Interface functions to looking up bindings} -%* * +%* * %************************************************************************ \begin{code} getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr) getCAddrModeIfVolatile id - = do { info <- getCgIdInfo id - ; case cg_stb info of - NoStableLoc -> do -- Aha! So it is volatile! - amode <- idInfoToAmode info - return $ Just amode - _ -> return Nothing } + = do { info <- getCgIdInfo id + ; case cg_stb info of + NoStableLoc -> do -- Aha! So it is volatile! + amode <- idInfoToAmode info + return $ Just amode + _ -> return Nothing } \end{code} @getVolatileRegs@ gets a set of live variables, and returns a list of -all registers on which these variables depend. These are the regs -which must be saved and restored across any C calls. If a variable is +all registers on which these variables depend. These are the regs +which must be saved and restored across any C calls. If a variable is both in a volatile location (depending on a register) {\em and} a stable one (notably, on the stack), we modify the current bindings to forget the volatile one. \begin{code} getVolatileRegs :: StgLiveVars -> FCode [GlobalReg] - getVolatileRegs vars = do - do { stuff <- mapFCs snaffle_it (varSetElems vars) - ; returnFC $ catMaybes stuff } + do { stuff <- mapFCs snaffle_it (varSetElems vars) + ; returnFC $ catMaybes stuff } where snaffle_it var = do - { info <- getCgIdInfo var - ; let - -- commoned-up code... - consider_reg reg - = -- We assume that all regs can die across C calls - -- We leave it to the save-macros to decide which - -- regs *really* need to be saved. - case cg_stb info of - NoStableLoc -> returnFC (Just reg) -- got one! - _ -> do - { -- has both volatile & stable locations; - -- force it to rely on the stable location - modifyBindC var nuke_vol_bind - ; return Nothing } - - ; case cg_vol info of - RegLoc (CmmGlobal reg) -> consider_reg reg - VirNodeLoc _ -> consider_reg node - _ -> returnFC Nothing -- Local registers - } + { info <- getCgIdInfo var + ; let + -- commoned-up code... + consider_reg reg + = -- We assume that all regs can die across C calls + -- We leave it to the save-macros to decide which + -- regs *really* need to be saved. + case cg_stb info of + NoStableLoc -> returnFC (Just reg) -- got one! + _ -> do + { -- has both volatile & stable locations; + -- force it to rely on the stable location + modifyBindC var nuke_vol_bind + ; return Nothing } + + ; case cg_vol info of + RegLoc (CmmGlobal reg) -> consider_reg reg + VirNodeLoc _ -> consider_reg node + _ -> returnFC Nothing -- Local registers + } nuke_vol_bind info = info { cg_vol = NoVolatileLoc } -\end{code} -\begin{code} getArgAmode :: StgArg -> FCode (CgRep, CmmExpr) getArgAmode (StgVarArg var) - = do { info <- getCgIdInfo var - ; amode <- idInfoToAmode info - ; return (cgIdInfoArgRep info, amode ) } + = do { info <- getCgIdInfo var + ; amode <- idInfoToAmode info + ; return (cgIdInfoArgRep info, amode ) } getArgAmode (StgLitArg lit) - = do { cmm_lit <- cgLit lit - ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } + = do { cmm_lit <- cgLit lit + ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" @@ -429,15 +417,15 @@ getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) | isStgTypeArg atom = getArgAmodes atoms - | otherwise = do { amode <- getArgAmode atom - ; amodes <- getArgAmodes atoms - ; return ( amode : amodes ) } + | otherwise = do { amode <- getArgAmode atom + ; amodes <- getArgAmodes atoms + ; return ( amode : amodes ) } \end{code} %************************************************************************ -%* * +%* * \subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names} -%* * +%* * %************************************************************************ \begin{code} @@ -466,22 +454,20 @@ bindNewToUntagNode id offset lf_info tag -- temporary. bindNewToTemp :: Id -> FCode LocalReg bindNewToTemp id - = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) - return temp_reg + = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) + return temp_reg where uniq = getUnique id temp_reg = LocalReg uniq (argMachRep (idCgRep id)) - lf_info = mkLFArgument id -- Always used of things we - -- know nothing about + lf_info = mkLFArgument id -- Always used of things we + -- know nothing about bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code bindNewToReg name reg lf_info = addBindC name info where info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info -\end{code} -\begin{code} rebindToStack :: Id -> VirtualSpOffset -> Code rebindToStack name offset = modifyBindC name replace_stable_fn @@ -490,19 +476,19 @@ rebindToStack name offset \end{code} %************************************************************************ -%* * +%* * \subsection[CgMonad-deadslots]{Finding dead stack slots} -%* * +%* * %************************************************************************ nukeDeadBindings does the following: - - Removes all bindings from the environment other than those - for variables in the argument to nukeDeadBindings. - - Collects any stack slots so freed, and returns them to the stack free - list. - - Moves the virtual stack pointer to point to the topmost used - stack locations. + - Removes all bindings from the environment other than those + for variables in the argument to nukeDeadBindings. + - Collects any stack slots so freed, and returns them to the stack free + list. + - Moves the virtual stack pointer to point to the topmost used + stack locations. You can have multi-word slots on the stack (where a Double# used to be, for instance); if dead, such a slot will be reported as *several* @@ -512,60 +498,56 @@ Probably *naughty* to look inside monad... \begin{code} nukeDeadBindings :: StgLiveVars -- All the *live* variables - -> Code + -> Code nukeDeadBindings live_vars = do - binds <- getBinds - let (dead_stk_slots, bs') = - dead_slots live_vars - [] [] - [ (cg_id b, b) | b <- varEnvElts binds ] - setBinds $ mkVarEnv bs' - freeStackSlots dead_stk_slots + binds <- getBinds + let (dead_stk_slots, bs') = + dead_slots live_vars + [] [] + [ (cg_id b, b) | b <- varEnvElts binds ] + setBinds $ mkVarEnv bs' + freeStackSlots dead_stk_slots \end{code} Several boring auxiliary functions to do the dirty work. \begin{code} dead_slots :: StgLiveVars - -> [(Id,CgIdInfo)] - -> [VirtualSpOffset] - -> [(Id,CgIdInfo)] - -> ([VirtualSpOffset], [(Id,CgIdInfo)]) + -> [(Id,CgIdInfo)] + -> [VirtualSpOffset] + -> [(Id,CgIdInfo)] + -> ([VirtualSpOffset], [(Id,CgIdInfo)]) -- dead_slots carries accumulating parameters for --- filtered bindings, dead slots +-- filtered bindings, dead slots dead_slots _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any dead_slots live_vars fbs ds ((v,i):bs) | v `elementOfUniqSet` live_vars = dead_slots live_vars ((v,i):fbs) ds bs - -- Live, so don't record it in dead slots - -- Instead keep it in the filtered bindings + -- Live, so don't record it in dead slots + -- Instead keep it in the filtered bindings | otherwise = case cg_stb i of - VirStkLoc offset - | size > 0 - -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs + VirStkLoc offset + | size > 0 + -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - _ -> dead_slots live_vars fbs ds bs + _ -> dead_slots live_vars fbs ds bs where size :: WordOff size = cgRepSizeW (cg_rep i) -\end{code} -\begin{code} getLiveStackSlots :: FCode [VirtualSpOffset] -- Return the offsets of slots in stack containig live pointers getLiveStackSlots - = do { binds <- getBinds - ; return [off | CgIdInfo { cg_stb = VirStkLoc off, - cg_rep = rep } <- varEnvElts binds, - isFollowableArg rep] } -\end{code} + = do { binds <- getBinds + ; return [off | CgIdInfo { cg_stb = VirStkLoc off, + cg_rep = rep } <- varEnvElts binds, + isFollowableArg rep] } -\begin{code} getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)] getLiveStackBindings = do { binds <- getBinds @@ -575,3 +557,4 @@ getLiveStackBindings cg_rep = rep} <- [bind], isFollowableArg rep] } \end{code} + diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 0a3911ea82..c65194b62f 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -4,34 +4,27 @@ -- -- CgCallConv -- --- The datatypes and functions here encapsulate the +-- The datatypes and functions here encapsulate the -- calling and return conventions used by the code generator. -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CgCallConv ( - -- Argument descriptors - mkArgDescr, + -- Argument descriptors + mkArgDescr, - -- Liveness - mkRegLiveness, + -- Liveness + mkRegLiveness, - -- Register assignment - assignCallRegs, assignReturnRegs, assignPrimOpCallRegs, + -- Register assignment + assignCallRegs, assignReturnRegs, assignPrimOpCallRegs, - -- Calls - constructSlowCall, slowArgs, slowCallPattern, + -- Calls + constructSlowCall, slowArgs, slowCallPattern, - -- Returns - dataReturnConvPrim, - getSequelAmode + -- Returns + dataReturnConvPrim, + getSequelAmode ) where import CgMonad @@ -57,11 +50,11 @@ import Data.Bits ------------------------------------------------------------------------- -- --- Making argument descriptors +-- Making argument descriptors -- -- An argument descriptor describes the layout of args on the stack, --- both for * GC (stack-layout) purposes, and --- * saving/restoring registers when a heap-check fails +-- both for * GC (stack-layout) purposes, and +-- * saving/restoring registers when a heap-check fails -- -- Void arguments aren't important, therefore (contrast constructSlowCall) -- @@ -72,29 +65,29 @@ import Data.Bits ------------------------- mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args +mkArgDescr _nm args = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) where arg_bits = argBits arg_reps arg_reps = filter nonVoidArg (map idCgRep args) - -- Getting rid of voids eases matching of standard patterns + -- Getting rid of voids eases matching of standard patterns -argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] +argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits [] = [] argBits (PtrArg : args) = False : argBits args argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args stdPattern :: [CgRep] -> Maybe StgHalfWord -stdPattern [] = Just ARG_NONE -- just void args, probably +stdPattern [] = Just ARG_NONE -- just void args, probably stdPattern [PtrArg] = Just ARG_P stdPattern [FloatArg] = Just ARG_F stdPattern [DoubleArg] = Just ARG_D stdPattern [LongArg] = Just ARG_L stdPattern [NonPtrArg] = Just ARG_N - + stdPattern [NonPtrArg,NonPtrArg] = Just ARG_NN stdPattern [NonPtrArg,PtrArg] = Just ARG_NP stdPattern [PtrArg,NonPtrArg] = Just ARG_PN @@ -103,13 +96,13 @@ stdPattern [PtrArg,PtrArg] = Just ARG_PP stdPattern [NonPtrArg,NonPtrArg,NonPtrArg] = Just ARG_NNN stdPattern [NonPtrArg,NonPtrArg,PtrArg] = Just ARG_NNP stdPattern [NonPtrArg,PtrArg,NonPtrArg] = Just ARG_NPN -stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP +stdPattern [NonPtrArg,PtrArg,PtrArg] = Just ARG_NPP stdPattern [PtrArg,NonPtrArg,NonPtrArg] = Just ARG_PNN -stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP -stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN -stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP - -stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP +stdPattern [PtrArg,NonPtrArg,PtrArg] = Just ARG_PNP +stdPattern [PtrArg,PtrArg,NonPtrArg] = Just ARG_PPN +stdPattern [PtrArg,PtrArg,PtrArg] = Just ARG_PPP + +stdPattern [PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPP stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPP stdPattern [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] = Just ARG_PPPPPP stdPattern _ = Nothing @@ -117,17 +110,17 @@ stdPattern _ = Nothing ------------------------------------------------------------------------- -- --- Bitmap describing register liveness --- across GC when doing a "generic" heap check --- (a RET_DYN stack frame). +-- Bitmap describing register liveness +-- across GC when doing a "generic" heap check +-- (a RET_DYN stack frame). -- --- NB. Must agree with these macros (currently in StgMacros.h): +-- NB. Must agree with these macros (currently in StgMacros.h): -- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS(). ------------------------------------------------------------------------- mkRegLiveness :: [(Id, GlobalReg)] -> Int -> Int -> StgWord mkRegLiveness regs ptrs nptrs - = (fromIntegral nptrs `shiftL` 16) .|. + = (fromIntegral nptrs `shiftL` 16) .|. (fromIntegral ptrs `shiftL` 24) .|. all_non_ptrs `xor` reg_bits regs where @@ -135,31 +128,31 @@ mkRegLiveness regs ptrs nptrs reg_bits [] = 0 reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id) - = (1 `shiftL` (i - 1)) .|. reg_bits regs + = (1 `shiftL` (i - 1)) .|. reg_bits regs reg_bits (_ : regs) - = reg_bits regs - + = reg_bits regs + ------------------------------------------------------------------------- -- --- Pushing the arguments for a slow call +-- Pushing the arguments for a slow call -- ------------------------------------------------------------------------- -- For a slow call, we must take a bunch of arguments and intersperse -- some stg_ap_<pattern>_ret_info return addresses. constructSlowCall - :: [(CgRep,CmmExpr)] - -> (CLabel, -- RTS entry point for call - [(CgRep,CmmExpr)], -- args to pass to the entry point - [(CgRep,CmmExpr)]) -- stuff to save on the stack + :: [(CgRep,CmmExpr)] + -> (CLabel, -- RTS entry point for call + [(CgRep,CmmExpr)], -- args to pass to the entry point + [(CgRep,CmmExpr)]) -- stuff to save on the stack -- don't forget the zero case -constructSlowCall [] +constructSlowCall [] = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], []) constructSlowCall amodes = (stg_ap_pat, these, rest) - where + where stg_ap_pat = mkRtsApFastLabel arg_pat (arg_pat, these, rest) = matchSlowPattern amodes @@ -178,33 +171,33 @@ slowArgs amodes save_cccs = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)] save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") -matchSlowPattern :: [(CgRep,CmmExpr)] - -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)]) +matchSlowPattern :: [(CgRep,CmmExpr)] + -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)]) matchSlowPattern amodes = (arg_pat, these, rest) where (arg_pat, n) = slowCallPattern (map fst amodes) - (these, rest) = splitAt n amodes + (these, rest) = splitAt n amodes -- These cases were found to cover about 99% of all slow calls: slowCallPattern :: [CgRep] -> (FastString, Int) slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5) -slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4) -slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4) -slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3) -slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3) -slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2) -slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2) -slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1) -slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1) -slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1) -slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1) -slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1) -slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1) -slowCallPattern _ = panic "CgStackery.slowCallPattern" +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppppp", 5) +slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppp", 4) +slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_pppv", 4) +slowCallPattern (PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_ppp", 3) +slowCallPattern (PtrArg: PtrArg: VoidArg: _) = (fsLit "stg_ap_ppv", 3) +slowCallPattern (PtrArg: PtrArg: _) = (fsLit "stg_ap_pp", 2) +slowCallPattern (PtrArg: VoidArg: _) = (fsLit "stg_ap_pv", 2) +slowCallPattern (PtrArg: _) = (fsLit "stg_ap_p", 1) +slowCallPattern (VoidArg: _) = (fsLit "stg_ap_v", 1) +slowCallPattern (NonPtrArg: _) = (fsLit "stg_ap_n", 1) +slowCallPattern (FloatArg: _) = (fsLit "stg_ap_f", 1) +slowCallPattern (DoubleArg: _) = (fsLit "stg_ap_d", 1) +slowCallPattern (LongArg: _) = (fsLit "stg_ap_l", 1) +slowCallPattern _ = panic "CgStackery.slowCallPattern" ------------------------------------------------------------------------- -- --- Return conventions +-- Return conventions -- ------------------------------------------------------------------------- @@ -219,7 +212,7 @@ dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void" -- getSequelAmode returns an amode which refers to an info table. The info -- table will always be of the RET_(BIG|SMALL) kind. We're careful --- not to handle real code pointers, just in case we're compiling for +-- not to handle real code pointers, just in case we're compiling for -- an unregisterised/untailcallish architecture, where info pointers and -- code pointers aren't the same. -- DIRE WARNING. @@ -230,60 +223,60 @@ dataReturnConvPrim VoidArg = panic "dataReturnConvPrim: void" getSequelAmode :: FCode CmmExpr getSequelAmode - = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo - ; case sequel of - OnStack -> do { sp_rel <- getSpRelOffset virt_sp - ; returnFC (CmmLoad sp_rel bWord) } + = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo + ; case sequel of + OnStack -> do { sp_rel <- getSpRelOffset virt_sp + ; returnFC (CmmLoad sp_rel bWord) } - CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) - } + CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) + } ------------------------------------------------------------------------- -- --- Register assignment +-- Register assignment -- ------------------------------------------------------------------------- --- How to assign registers for +-- How to assign registers for -- --- 1) Calling a fast entry point. --- 2) Returning an unboxed tuple. --- 3) Invoking an out-of-line PrimOp. +-- 1) Calling a fast entry point. +-- 2) Returning an unboxed tuple. +-- 3) Invoking an out-of-line PrimOp. -- -- Registers are assigned in order. --- +-- -- If we run out, we don't attempt to assign any further registers (even -- though we might have run out of only one kind of register); we just -- return immediately with the left-overs specified. --- +-- -- The alternative version @assignAllRegs@ uses the complete set of -- registers, including those that aren't mapped to real machine -- registers. This is used for calling special RTS functions and PrimOps -- which expect their arguments to always be in the same registers. assignCallRegs, assignPrimOpCallRegs, assignReturnRegs - :: [(CgRep,a)] -- Arg or result values to assign - -> ([(a, GlobalReg)], -- Register assignment in same order - -- for *initial segment of* input list - -- (but reversed; doesn't matter) - -- VoidRep args do not appear here - [(CgRep,a)]) -- Leftover arg or result values + :: [(CgRep,a)] -- Arg or result values to assign + -> ([(a, GlobalReg)], -- Register assignment in same order + -- for *initial segment of* input list + -- (but reversed; doesn't matter) + -- VoidRep args do not appear here + [(CgRep,a)]) -- Leftover arg or result values assignCallRegs args = assign_regs args (mkRegTbl [node]) - -- The entry convention for a function closure - -- never uses Node for argument passing; instead - -- Node points to the function closure itself + -- The entry convention for a function closure + -- never uses Node for argument passing; instead + -- Node points to the function closure itself assignPrimOpCallRegs args = assign_regs args (mkRegTbl_allRegs []) - -- For primops, *all* arguments must be passed in registers + -- For primops, *all* arguments must be passed in registers assignReturnRegs args -- when we have a single non-void component to return, use the normal -- unpointed return convention. This make various things simpler: it -- means we can assume a consistent convention for IO, which is useful - -- when writing code that relies on knowing the IO return convention in + -- when writing code that relies on knowing the IO return convention in -- the RTS (primops, especially exception-related primops). -- Also, the bytecode compiler assumes this when compiling -- case expressions and ccalls, so it only needs to know one set of @@ -292,24 +285,24 @@ assignReturnRegs args = ([(arg, r)], []) | otherwise = assign_regs args (mkRegTbl []) - -- For returning unboxed tuples etc, - -- we use all regs - where + -- For returning unboxed tuples etc, + -- we use all regs + where non_void_args = filter ((/= VoidArg).fst) args -assign_regs :: [(CgRep,a)] -- Arg or result values to assign - -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs - -> ([(a, GlobalReg)], [(CgRep, a)]) +assign_regs :: [(CgRep,a)] -- Arg or result values to assign + -> AvailRegs -- Regs still avail: Vanilla, Float, Double, Longs + -> ([(a, GlobalReg)], [(CgRep, a)]) assign_regs args supply = go args [] supply where - go [] acc _ = (acc, []) -- Return the results reversed (doesn't matter) - go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and - = go args acc supply -- there's nothing to bind them to - go ((rep,arg) : args) acc supply - = case assign_reg rep supply of - Just (reg, supply') -> go args ((arg,reg):acc) supply' - Nothing -> (acc, (rep,arg):args) -- No more regs + go [] acc _ = (acc, []) -- Return the results reversed (doesn't matter) + go ((VoidArg,_) : args) acc supply -- Skip void arguments; they aren't passed, and + = go args acc supply -- there's nothing to bind them to + go ((rep,arg) : args) acc supply + = case assign_reg rep supply of + Just (reg, supply') -> go args ((arg,reg):acc) supply' + Nothing -> (acc, (rep,arg):args) -- No more regs assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs) assign_reg FloatArg (vs, f:fs, ds, ls) = Just (FloatReg f, (vs, fs, ds, ls)) @@ -323,7 +316,7 @@ assign_reg _ _ = Nothing ------------------------------------------------------------------------- -- --- Register supplies +-- Register supplies -- ------------------------------------------------------------------------- @@ -335,37 +328,37 @@ assign_reg _ _ = Nothing useVanillaRegs :: Int useVanillaRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Vanilla_REG + | otherwise = mAX_Real_Vanilla_REG useFloatRegs :: Int useFloatRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Float_REG + | otherwise = mAX_Real_Float_REG useDoubleRegs :: Int useDoubleRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Double_REG + | otherwise = mAX_Real_Double_REG useLongRegs :: Int useLongRegs | opt_Unregisterised = 0 - | otherwise = mAX_Real_Long_REG + | otherwise = mAX_Real_Long_REG vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int] -vanillaRegNos = regList useVanillaRegs -floatRegNos = regList useFloatRegs -doubleRegNos = regList useDoubleRegs +vanillaRegNos = regList useVanillaRegs +floatRegNos = regList useFloatRegs +doubleRegNos = regList useDoubleRegs longRegNos = regList useLongRegs allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int] allVanillaRegNos = regList mAX_Vanilla_REG -allFloatRegNos = regList mAX_Float_REG -allDoubleRegNos = regList mAX_Double_REG -allLongRegNos = regList mAX_Long_REG +allFloatRegNos = regList mAX_Float_REG +allDoubleRegNos = regList mAX_Double_REG +allLongRegNos = regList mAX_Long_REG regList :: Int -> [Int] regList n = [1 .. n] type AvailRegs = ( [Int] -- available vanilla regs. - , [Int] -- floats - , [Int] -- doubles - , [Int] -- longs (int64 and word64) - ) + , [Int] -- floats + , [Int] -- doubles + , [Int] -- longs (int64 and word64) + ) mkRegTbl :: [GlobalReg] -> AvailRegs mkRegTbl regs_in_use @@ -381,23 +374,23 @@ mkRegTbl' regs_in_use vanillas floats doubles longs = (ok_vanilla, ok_float, ok_double, ok_long) where ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) vanillas - -- ptrhood isn't looked at, hence we can use any old rep. - ok_float = mapCatMaybes (select FloatReg) floats + -- ptrhood isn't looked at, hence we can use any old rep. + ok_float = mapCatMaybes (select FloatReg) floats ok_double = mapCatMaybes (select DoubleReg) doubles - ok_long = mapCatMaybes (select LongReg) longs + ok_long = mapCatMaybes (select LongReg) longs select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int - -- one we've unboxed the Int, we make a GlobalReg - -- and see if it is already in use; if not, return its number. + -- one we've unboxed the Int, we make a GlobalReg + -- and see if it is already in use; if not, return its number. select mk_reg_fun cand = let - reg = mk_reg_fun cand - in - if reg `not_elem` regs_in_use - then Just cand - else Nothing + reg = mk_reg_fun cand + in + if reg `not_elem` regs_in_use + then Just cand + else Nothing where - not_elem = isn'tIn "mkRegTbl" + not_elem = isn'tIn "mkRegTbl" diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index a36621bdaf..dd607de1fc 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -4,20 +4,16 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details -module CgCase ( cgCase, saveVolatileVarsAndRegs, - restoreCurrentCostCentre - ) where +module CgCase ( + cgCase, + saveVolatileVarsAndRegs, + restoreCurrentCostCentre + ) where #include "HsVersions.h" -import {-# SOURCE #-} CgExpr ( cgExpr ) +import {-# SOURCE #-} CgExpr ( cgExpr ) import CgMonad import CgBindery @@ -54,12 +50,12 @@ import Control.Monad (when) \begin{code} data GCFlag - = GCMayHappen -- The scrutinee may involve GC, so everything must be - -- tidy before the code for the scrutinee. + = GCMayHappen -- The scrutinee may involve GC, so everything must be + -- tidy before the code for the scrutinee. - | NoGC -- The scrutinee is a primitive value, or a call to a - -- primitive op which does no GC. Hence the case can - -- be done inline, without tidying up first. + | NoGC -- The scrutinee is a primitive value, or a call to a + -- primitive op which does no GC. Hence the case can + -- be done inline, without tidying up first. \end{code} It is quite interesting to decide whether to put a heap-check @@ -70,11 +66,11 @@ op which can trigger GC. A more interesting situation is this: \begin{verbatim} - !A!; - ...A... - case x# of - 0# -> !B!; ...B... - default -> !C!; ...C... + !A!; + ...A... + case x# of + 0# -> !B!; ...B... + default -> !C!; ...C... \end{verbatim} where \tr{!x!} indicates a possible heap-check point. The heap checks @@ -84,29 +80,29 @@ heapcheck will take their worst case into account. In favour of omitting \tr{!B!}, \tr{!C!}: - {\em May} save a heap overflow test, - if ...A... allocates anything. The other advantage - of this is that we can use relative addressing - from a single Hp to get at all the closures so allocated. + if ...A... allocates anything. The other advantage + of this is that we can use relative addressing + from a single Hp to get at all the closures so allocated. - No need to save volatile vars etc across the case Against: - May do more allocation than reqd. This sometimes bites us - badly. For example, nfib (ha!) allocates about 30\% more space if the - worst-casing is done, because many many calls to nfib are leaf calls - which don't need to allocate anything. + badly. For example, nfib (ha!) allocates about 30\% more space if the + worst-casing is done, because many many calls to nfib are leaf calls + which don't need to allocate anything. - This never hurts us if there is only one alternative. + This never hurts us if there is only one alternative. \begin{code} -cgCase :: StgExpr - -> StgLiveVars - -> StgLiveVars - -> Id - -> AltType - -> [StgAlt] - -> Code +cgCase :: StgExpr + -> StgLiveVars + -> StgLiveVars + -> Id + -> AltType + -> [StgAlt] + -> Code \end{code} Special case #1: case of literal. @@ -114,15 +110,15 @@ Special case #1: case of literal. \begin{code} cgCase (StgLit lit) _live_in_whole_case _live_in_alts bndr alt_type@(PrimAlt _) alts - = do { tmp_reg <- bindNewToTemp bndr - ; cm_lit <- cgLit lit - ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit)) - ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } + = do { tmp_reg <- bindNewToTemp bndr + ; cm_lit <- cgLit lit + ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit)) + ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } \end{code} -Special case #2: scrutinising a primitive-typed variable. No +Special case #2: scrutinising a primitive-typed variable. No evaluation required. We don't save volatile variables, nor do we do a -heap-check in the alternatives. Instead, the heap usage of the +heap-check in the alternatives. Instead, the heap usage of the alternatives is worst-cased and passed upstream. This can result in allocating more heap than strictly necessary, but it will sometimes eliminate a heap check altogether. @@ -159,15 +155,15 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" -- Careful! we can't just bind the default binder to the same thing - -- as the scrutinee, since it might be a stack location, and having - -- two bindings pointing at the same stack locn doesn't work (it - -- confuses nukeDeadBindings). Hence, use a new temp. - ; v_info <- getCgIdInfo v - ; amode <- idInfoToAmode v_info - ; tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign (CmmLocal tmp_reg) amode) - - ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } + -- as the scrutinee, since it might be a stack location, and having + -- two bindings pointing at the same stack locn doesn't work (it + -- confuses nukeDeadBindings). Hence, use a new temp. + ; v_info <- getCgIdInfo v + ; amode <- idInfoToAmode v_info + ; tmp_reg <- bindNewToTemp bndr + ; stmtC (CmmAssign (CmmLocal tmp_reg) amode) + + ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts } where reps_compatible = idCgRep v == idCgRep bndr \end{code} @@ -194,7 +190,7 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) Special case #3: inline PrimOps and foreign calls. \begin{code} -cgCase (StgOpApp (StgPrimOp primop) args _) +cgCase (StgOpApp (StgPrimOp primop) args _) _live_in_whole_case live_in_alts bndr alt_type alts | not (primOpOutOfLine primop) = cgInlinePrimOp primop args bndr alt_type live_in_alts alts @@ -209,23 +205,23 @@ Special case #4: inline foreign calls: an unsafe foreign call can be done right here, just like an inline primop. \begin{code} -cgCase (StgOpApp (StgFCallOp fcall _) args _) +cgCase (StgOpApp (StgFCallOp fcall _) args _) _live_in_whole_case live_in_alts _bndr _alt_type alts | unsafe_foreign_call = ASSERT( isSingleton alts ) - do -- *must* be an unboxed tuple alt. - -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. - { res_tmps <- mapFCs bindNewToTemp non_void_res_ids - ; let res_hints = map (typeForeignHint.idType) non_void_res_ids - ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts - ; cgExpr rhs } + do -- *must* be an unboxed tuple alt. + -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. + { res_tmps <- mapFCs bindNewToTemp non_void_res_ids + ; let res_hints = map (typeForeignHint.idType) non_void_res_ids + ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts + ; cgExpr rhs } where (_, res_ids, _, rhs) = head alts non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids unsafe_foreign_call - = case fcall of - CCall (CCallSpec _ _ s) -> not (playSafe s) + = case fcall of + CCall (CCallSpec _ _ s) -> not (playSafe s) \end{code} Special case: scrutinising a non-primitive variable. @@ -234,28 +230,28 @@ we can reuse/trim the stack slot holding the variable (if it is in one). \begin{code} cgCase (StgApp fun args) - _live_in_whole_case live_in_alts bndr alt_type alts - = do { fun_info <- getCgIdInfo fun - ; arg_amodes <- getArgAmodes args - - -- Nuking dead bindings *before* calculating the saves is the - -- value-add here. We might end up freeing up some slots currently - -- occupied by variables only required for the call. - -- NOTE: we need to look up the variables used in the call before - -- doing this, because some of them may not be in the environment - -- afterward. - ; nukeDeadBindings live_in_alts - ; (save_assts, alts_eob_info, maybe_cc_slot) - <- saveVolatileVarsAndRegs live_in_alts - - ; scrut_eob_info - <- forkEval alts_eob_info - (allocStackTop retAddrSizeW >> nopC) - (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - - ; setEndOfBlockInfo scrut_eob_info - (performTailCall fun_info arg_amodes save_assts) } + _live_in_whole_case live_in_alts bndr alt_type alts + = do { fun_info <- getCgIdInfo fun + ; arg_amodes <- getArgAmodes args + + -- Nuking dead bindings *before* calculating the saves is the + -- value-add here. We might end up freeing up some slots currently + -- occupied by variables only required for the call. + -- NOTE: we need to look up the variables used in the call before + -- doing this, because some of them may not be in the environment + -- afterward. + ; nukeDeadBindings live_in_alts + ; (save_assts, alts_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_alts + + ; scrut_eob_info + <- forkEval alts_eob_info + (allocStackTop retAddrSizeW >> nopC) + (do { deAllocStackTop retAddrSizeW + ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) + + ; setEndOfBlockInfo scrut_eob_info + (performTailCall fun_info arg_amodes save_assts) } \end{code} Note about return addresses: we *always* push a return address, even @@ -273,25 +269,25 @@ Finally, here is the general case. \begin{code} cgCase expr live_in_whole_case live_in_alts bndr alt_type alts - = do { -- Figure out what volatile variables to save - nukeDeadBindings live_in_whole_case - - ; (save_assts, alts_eob_info, maybe_cc_slot) - <- saveVolatileVarsAndRegs live_in_alts - - -- Save those variables right now! - ; emitStmts save_assts - - -- generate code for the alts - ; scrut_eob_info - <- forkEval alts_eob_info - (do { nukeDeadBindings live_in_alts - ; allocStackTop retAddrSizeW -- space for retn address - ; nopC }) - (do { deAllocStackTop retAddrSizeW - ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) - - ; setEndOfBlockInfo scrut_eob_info (cgExpr expr) + = do { -- Figure out what volatile variables to save + nukeDeadBindings live_in_whole_case + + ; (save_assts, alts_eob_info, maybe_cc_slot) + <- saveVolatileVarsAndRegs live_in_alts + + -- Save those variables right now! + ; emitStmts save_assts + + -- generate code for the alts + ; scrut_eob_info + <- forkEval alts_eob_info + (do { nukeDeadBindings live_in_alts + ; allocStackTop retAddrSizeW -- space for retn address + ; nopC }) + (do { deAllocStackTop retAddrSizeW + ; cgEvalAlts maybe_cc_slot bndr alt_type alts }) + + ; setEndOfBlockInfo scrut_eob_info (cgExpr expr) } \end{code} @@ -300,15 +296,15 @@ stack pointer here. forkEval takes the virtual Sp and free list from the first argument, and turns that into the *real* Sp for the second argument. It also uses this virtual Sp as the args-Sp in the EOB info returned, so that the scrutinee will trim the real Sp back to the -right place before doing whatever it does. - --SDM (who just spent an hour figuring this out, and didn't want to - forget it). +right place before doing whatever it does. + --SDM (who just spent an hour figuring this out, and didn't want to + forget it). Why don't we push the return address just before evaluating the scrutinee? Because the slot reserved for the return address might contain something useful, so we wait until performing a tail call or return before pushing the return address (see -CgTailCall.pushReturnAddress). +CgTailCall.pushReturnAddress). This also means that the environment doesn't need to know about the free stack slot for the return address (for generating bitmaps), @@ -322,9 +318,9 @@ follow the layout of closures when we're profiling. The CCS could be anywhere within the record). %************************************************************************ -%* * - Inline primops -%* * +%* * + Inline primops +%* * %************************************************************************ \begin{code} @@ -334,78 +330,78 @@ cgInlinePrimOp :: PrimOp -> [StgArg] -> Id -> AltType -> StgLiveVars cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts | isVoidArg (idCgRep bndr) = ASSERT( con == DEFAULT && isSingleton alts && null bs ) - do { -- VOID RESULT; just sequencing, - -- so get in there and do it - -- The bndr should not occur, so no need to bind it - cgPrimOp [] primop args live_in_alts - ; cgExpr rhs } + do { -- VOID RESULT; just sequencing, + -- so get in there and do it + -- The bndr should not occur, so no need to bind it + cgPrimOp [] primop args live_in_alts + ; cgExpr rhs } where (con,bs,_,rhs) = head alts cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts - = do { -- PRIMITIVE ALTS, with non-void result - tmp_reg <- bindNewToTemp bndr - ; cgPrimOp [tmp_reg] primop args live_in_alts - ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts } + = do { -- PRIMITIVE ALTS, with non-void result + tmp_reg <- bindNewToTemp bndr + ; cgPrimOp [tmp_reg] primop args live_in_alts + ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts } cgInlinePrimOp primop args _ (UbxTupAlt _) live_in_alts alts = ASSERT( isSingleton alts ) - do { -- UNBOXED TUPLE ALTS - -- No heap check, no yield, just get in there and do it. - -- NB: the case binder isn't bound to anything; - -- it has a unboxed tuple type - - res_tmps <- mapFCs bindNewToTemp non_void_res_ids - ; cgPrimOp res_tmps primop args live_in_alts - ; cgExpr rhs } + do { -- UNBOXED TUPLE ALTS + -- No heap check, no yield, just get in there and do it. + -- NB: the case binder isn't bound to anything; + -- it has a unboxed tuple type + + res_tmps <- mapFCs bindNewToTemp non_void_res_ids + ; cgPrimOp res_tmps primop args live_in_alts + ; cgExpr rhs } where (_, res_ids, _, rhs) = head alts non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts - = do { -- ENUMERATION TYPE RETURN - -- Typical: case a ># b of { True -> ..; False -> .. } - -- The primop itself returns an index into the table of - -- closures for the enumeration type. - tag_amode <- ASSERT( isEnumerationTyCon tycon ) - do_enum_primop primop - - -- Bind the default binder if necessary - -- (avoiding it avoids the assignment) - -- The deadness info is set by StgVarInfo - ; whenC (not (isDeadBinder bndr)) - (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign + = do { -- ENUMERATION TYPE RETURN + -- Typical: case a ># b of { True -> ..; False -> .. } + -- The primop itself returns an index into the table of + -- closures for the enumeration type. + tag_amode <- ASSERT( isEnumerationTyCon tycon ) + do_enum_primop primop + + -- Bind the default binder if necessary + -- (avoiding it avoids the assignment) + -- The deadness info is set by StgVarInfo + ; whenC (not (isDeadBinder bndr)) + (do { tmp_reg <- bindNewToTemp bndr + ; stmtC (CmmAssign (CmmLocal tmp_reg) (tagToClosure tycon tag_amode)) }) - -- Compile the alts - ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} - (AlgAlt tycon) alts + -- Compile the alts + ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} + (AlgAlt tycon) alts - -- Do the switch - ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1) - } + -- Do the switch + ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1) + } where - do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result - do_enum_primop TagToEnumOp -- No code! + do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result + do_enum_primop TagToEnumOp -- No code! | [arg] <- args = do (_,e) <- getArgAmode arg - return e + return e do_enum_primop primop = do tmp <- newTemp bWord - cgPrimOp [tmp] primop args live_in_alts - returnFC (CmmReg (CmmLocal tmp)) + cgPrimOp [tmp] primop args live_in_alts + returnFC (CmmReg (CmmLocal tmp)) cgInlinePrimOp _ _ bndr _ _ _ = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr) \end{code} %************************************************************************ -%* * +%* * \subsection[CgCase-alts]{Alternatives} -%* * +%* * %************************************************************************ @cgEvalAlts@ returns an addressing mode for a continuation for the @@ -413,77 +409,77 @@ alternatives of a @case@, used in a context when there is some evaluation to be done. \begin{code} -cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any - -> Id - -> AltType - -> [StgAlt] - -> FCode Sequel -- Any addr modes inside are guaranteed - -- to be a label so that we can duplicate it - -- without risk of duplicating code +cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any + -> Id + -> AltType + -> [StgAlt] + -> FCode Sequel -- Any addr modes inside are guaranteed + -- to be a label so that we can duplicate it + -- without risk of duplicating code cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts - = do { let rep = tyConCgRep tycon - reg = dataReturnConvPrim rep -- Bottom for voidRep + = do { let rep = tyConCgRep tycon + reg = dataReturnConvPrim rep -- Bottom for voidRep - ; abs_c <- forkProc $ do - { -- Bind the case binder, except if it's void - -- (reg is bottom in that case) - whenC (nonVoidArg rep) $ - bindNewToReg bndr reg (mkLFArgument bndr) - ; restoreCurrentCostCentre cc_slot True - ; cgPrimAlts GCMayHappen alt_type reg alts } + ; abs_c <- forkProc $ do + { -- Bind the case binder, except if it's void + -- (reg is bottom in that case) + whenC (nonVoidArg rep) $ + bindNewToReg bndr reg (mkLFArgument bndr) + ; restoreCurrentCostCentre cc_slot True + ; cgPrimAlts GCMayHappen alt_type reg alts } - ; lbl <- emitReturnTarget (idName bndr) abs_c - ; returnFC (CaseAlts lbl Nothing bndr) } + ; lbl <- emitReturnTarget (idName bndr) abs_c + ; returnFC (CaseAlts lbl Nothing bndr) } cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)] - = -- Unboxed tuple case - -- By now, the simplifier should have have turned it - -- into case e of (# a,b #) -> e - -- There shouldn't be a - -- case e of DEFAULT -> e + = -- Unboxed tuple case + -- By now, the simplifier should have have turned it + -- into case e of (# a,b #) -> e + -- There shouldn't be a + -- case e of DEFAULT -> e ASSERT2( case con of { DataAlt _ -> True; _ -> False }, - text "cgEvalAlts: dodgy case of unboxed tuple type" ) - do { -- forkAbsC for the RHS, so that the envt is - -- not changed for the emitReturn call - abs_c <- forkProc $ do - { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args - -- Restore the CC *after* binding the tuple components, - -- so that we get the stack offset of the saved CC right. - ; restoreCurrentCostCentre cc_slot True - -- Generate a heap check if necessary - -- and finally the code for the alternative - ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts - (cgExpr rhs) } - ; lbl <- emitReturnTarget (idName bndr) abs_c - ; returnFC (CaseAlts lbl Nothing bndr) } + text "cgEvalAlts: dodgy case of unboxed tuple type" ) + do { -- forkAbsC for the RHS, so that the envt is + -- not changed for the emitReturn call + abs_c <- forkProc $ do + { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args + -- Restore the CC *after* binding the tuple components, + -- so that we get the stack offset of the saved CC right. + ; restoreCurrentCostCentre cc_slot True + -- Generate a heap check if necessary + -- and finally the code for the alternative + ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts + (cgExpr rhs) } + ; lbl <- emitReturnTarget (idName bndr) abs_c + ; returnFC (CaseAlts lbl Nothing bndr) } cgEvalAlts cc_slot bndr alt_type alts - = -- Algebraic and polymorphic case - do { -- Bind the default binder - bindNewToReg bndr nodeReg (mkLFArgument bndr) + = -- Algebraic and polymorphic case + do { -- Bind the default binder + bindNewToReg bndr nodeReg (mkLFArgument bndr) - -- Generate sequel info for use downstream - -- At the moment, we only do it if the type is vector-returnable. - -- Reason: if not, then it costs extra to label the - -- alternatives, because we'd get return code like: - -- - -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc } - -- - -- which is worse than having the alt code in the switch statement + -- Generate sequel info for use downstream + -- At the moment, we only do it if the type is vector-returnable. + -- Reason: if not, then it costs extra to label the + -- alternatives, because we'd get return code like: + -- + -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc } + -- + -- which is worse than having the alt code in the switch statement - ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts + ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts - ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) - alts mb_deflt fam_sz + ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) + alts mb_deflt fam_sz - ; returnFC (CaseAlts lbl branches bndr) } + ; returnFC (CaseAlts lbl branches bndr) } where fam_sz = case alt_type of - AlgAlt tc -> tyConFamilySize tc - PolyAlt -> 0 - PrimAlt _ -> panic "cgEvalAlts: PrimAlt" - UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt" + AlgAlt tc -> tyConFamilySize tc + PolyAlt -> 0 + PrimAlt _ -> panic "cgEvalAlts: PrimAlt" + UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt" \end{code} @@ -494,9 +490,9 @@ must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be emitted). Hence, the new Bool arg to cgAlgAltRhs. %************************************************************************ -%* * +%* * \subsection[CgCase-alg-alts]{Algebraic alternatives} -%* * +%* * %************************************************************************ In @cgAlgAlts@, none of the binders in the alternatives are @@ -510,36 +506,36 @@ are inlined alternatives. \begin{code} cgAlgAlts :: GCFlag -> Maybe VirtualSpOffset - -> AltType -- ** AlgAlt or PolyAlt only ** - -> [StgAlt] -- The alternatives + -> AltType -- ** AlgAlt or PolyAlt only ** + -> [StgAlt] -- The alternatives -> FCode ( [(ConTagZ, CgStmts)], -- The branches - Maybe CgStmts ) -- The default case + Maybe CgStmts ) -- The default case cgAlgAlts gc_flag cc_slot alt_type alts = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts] let - mb_deflt = case alts of -- DEFAULT is always first, if present - ((DEFAULT,blks) : _) -> Just blks - _ -> Nothing + mb_deflt = case alts of -- DEFAULT is always first, if present + ((DEFAULT,blks) : _) -> Just blks + _ -> Nothing - branches = [(dataConTagZ con, blks) - | (DataAlt con, blks) <- alts] + branches = [(dataConTagZ con, blks) + | (DataAlt con, blks) <- alts] -- in return (branches, mb_deflt) cgAlgAlt :: GCFlag - -> Maybe VirtualSpOffset -- Turgid state - -> AltType -- ** AlgAlt or PolyAlt only ** - -> StgAlt - -> FCode (AltCon, CgStmts) + -> Maybe VirtualSpOffset -- Turgid state + -> AltType -- ** AlgAlt or PolyAlt only ** + -> StgAlt + -> FCode (AltCon, CgStmts) cgAlgAlt gc_flag cc_slot alt_type (con, args, _use_mask, rhs) - = do { abs_c <- getCgStmts $ do - { bind_con_args con args - ; restoreCurrentCostCentre cc_slot True - ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } - ; return (con, abs_c) } + = do { abs_c <- getCgStmts $ do + { bind_con_args con args + ; restoreCurrentCostCentre cc_slot True + ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) } + ; return (con, abs_c) } where bind_con_args DEFAULT _ = nopC bind_con_args (DataAlt dc) args = bindConArgs dc args @@ -548,9 +544,9 @@ cgAlgAlt gc_flag cc_slot alt_type (con, args, _use_mask, rhs) %************************************************************************ -%* * +%* * \subsection[CgCase-prim-alts]{Primitive alternatives} -%* * +%* * %************************************************************************ @cgPrimAlts@ generates suitable a @CSwitch@ @@ -562,10 +558,10 @@ As usual, no binders in the alternatives are yet bound. \begin{code} cgPrimAlts :: GCFlag - -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck - -> CmmReg -- Scrutinee - -> [StgAlt] -- Alternatives - -> Code + -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck + -> CmmReg -- Scrutinee + -> [StgAlt] -- Alternatives + -> Code -- NB: cgPrimAlts emits code that does the case analysis. -- It's often used in inline situations, rather than to genearte -- a labelled return point. That's why its interface is a little @@ -573,73 +569,73 @@ cgPrimAlts :: GCFlag -- -- INVARIANT: the default binder is already bound cgPrimAlts gc_flag alt_type scrutinee alts - = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts) - ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default - alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others] - ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC } + = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts) + ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default + alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others] + ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC } cgPrimAlt :: GCFlag - -> AltType - -> StgAlt -- The alternative - -> FCode (AltCon, CgStmts) -- Its compiled form + -> AltType + -> StgAlt -- The alternative + -> FCode (AltCon, CgStmts) -- Its compiled form cgPrimAlt gc_flag alt_type (con, [], [], rhs) = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; _ -> False } ) - do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) - ; returnFC (con, abs_c) } + do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) + ; returnFC (con, abs_c) } cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists" \end{code} %************************************************************************ -%* * +%* * \subsection[CgCase-tidy]{Code for tidying up prior to an eval} -%* * +%* * %************************************************************************ \begin{code} -maybeAltHeapCheck - :: GCFlag - -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt - -> Code -- Continuation - -> Code -maybeAltHeapCheck NoGC _ code = code +maybeAltHeapCheck + :: GCFlag + -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt + -> Code -- Continuation + -> Code +maybeAltHeapCheck NoGC _ code = code maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code saveVolatileVarsAndRegs :: StgLiveVars -- Vars which should be made safe - -> FCode (CmmStmts, -- Assignments to do the saves - EndOfBlockInfo, -- sequel for the alts + -> FCode (CmmStmts, -- Assignments to do the saves + EndOfBlockInfo, -- sequel for the alts Maybe VirtualSpOffset) -- Slot for current cost centre saveVolatileVarsAndRegs vars - = do { var_saves <- saveVolatileVars vars - ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre - ; eob_info <- getEndOfBlockInfo - ; returnFC (var_saves `plusStmts` cc_save, - eob_info, - maybe_cc_slot) } + = do { var_saves <- saveVolatileVars vars + ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre + ; eob_info <- getEndOfBlockInfo + ; returnFC (var_saves `plusStmts` cc_save, + eob_info, + maybe_cc_slot) } -saveVolatileVars :: StgLiveVars -- Vars which should be made safe - -> FCode CmmStmts -- Assignments to to the saves +saveVolatileVars :: StgLiveVars -- Vars which should be made safe + -> FCode CmmStmts -- Assignments to to the saves saveVolatileVars vars - = do { stmts_s <- mapFCs save_it (varSetElems vars) - ; return (foldr plusStmts noStmts stmts_s) } + = do { stmts_s <- mapFCs save_it (varSetElems vars) + ; return (foldr plusStmts noStmts stmts_s) } where save_it var = do { v <- getCAddrModeIfVolatile var - ; case v of - Nothing -> return noStmts -- Non-volatile - Just vol_amode -> save_var var vol_amode -- Aha! It's volatile - } + ; case v of + Nothing -> return noStmts -- Non-volatile + Just vol_amode -> save_var var vol_amode -- Aha! It's volatile + } save_var var vol_amode = do { slot <- allocPrimStack (idCgRep var) - ; rebindToStack var slot - ; sp_rel <- getSpRelOffset slot - ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) } + ; rebindToStack var slot + ; sp_rel <- getSpRelOffset slot + ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) } \end{code} --------------------------------------------------------------------------- @@ -651,25 +647,25 @@ virtual offset of the location, to pass on to the alternatives, and \begin{code} saveCurrentCostCentre :: - FCode (Maybe VirtualSpOffset, -- Where we decide to store it - CmmStmts) -- Assignment to save it + FCode (Maybe VirtualSpOffset, -- Where we decide to store it + CmmStmts) -- Assignment to save it saveCurrentCostCentre - | not opt_SccProfilingOn + | not opt_SccProfilingOn = returnFC (Nothing, noStmts) | otherwise - = do { slot <- allocPrimStack PtrArg - ; sp_rel <- getSpRelOffset slot - ; returnFC (Just slot, - oneStmt (CmmStore sp_rel curCCS)) } + = do { slot <- allocPrimStack PtrArg + ; sp_rel <- getSpRelOffset slot + ; returnFC (Just slot, + oneStmt (CmmStore sp_rel curCCS)) } -- Sometimes we don't free the slot containing the cost centre after restoring it -- (see CgLetNoEscape.cgLetNoEscapeBody). restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code restoreCurrentCostCentre Nothing _freeit = nopC restoreCurrentCostCentre (Just slot) freeit - = do { sp_rel <- getSpRelOffset slot - ; whenC freeit (freeStackSlots [slot]) + = do { sp_rel <- getSpRelOffset slot + ; whenC freeit (freeStackSlots [slot]) ; stmtC (storeCurCCS (CmmLoad sp_rel bWord)) } \end{code} diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 7bad8516d9..d6537c27e5 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -362,6 +362,7 @@ mkSlowEntryCode cl_info reg_args = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) 0 reps_w_regs + load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) (CmmLoad (cmmRegOffW spReg offset) @@ -374,7 +375,8 @@ mkSlowEntryCode cl_info reg_args stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) - jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) [] + live_regs = Just $ map snd reps_w_regs + jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) live_regs \end{code} @@ -412,6 +414,7 @@ funWrapper :: ClosureInfo -- Closure whose code body this is -> Code funWrapper closure_info arg_regs reg_save_code fun_body = do { let node_points = nodeMustPointToIt (closureLFInfo closure_info) + live = Just $ map snd arg_regs {- -- Debugging: check that R1 has the correct tag @@ -431,8 +434,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do ; granYield arg_regs node_points -- Heap and/or stack checks wrap the function body - ; funEntryChecks closure_info reg_save_code - fun_body + ; funEntryChecks closure_info reg_save_code live fun_body } \end{code} @@ -590,7 +592,7 @@ link_caf cl_info _is_upd = do -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in - stmtC (CmmJump target []) + stmtC (CmmJump target $ Just [node]) ; returnFC hp_rel } where diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 17bb9d0ad8..9049504dca 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -116,7 +116,7 @@ buildDynCon :: Id -- Name of the thing to which this constr will -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor - -> [(CgRep,CmmExpr)] -- Its args + -> [(CgRep,CmmExpr)] -- Its args -> FCode CgIdInfo -- Return details about how to find it buildDynCon binder ccs con args = do dflags <- getDynFlags @@ -348,12 +348,15 @@ cgReturnDataCon con amodes | otherwise -> build_it_then (jump_to deflt_lbl) } _otherwise -- The usual case - -> build_it_then emitReturnInstr + -> build_it_then $ emitReturnInstr node_live } where + node_live = Just [node] enter_it = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), - CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg))) [] ] - jump_to lbl = stmtC (CmmJump (CmmLit lbl) []) + CmmJump (entryCode $ closureInfoPtr $ CmmReg nodeReg) + node_live + ] + jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live build_it_then return_code = do { -- BUILD THE OBJECT IN THE HEAP -- The first "con" says that the name bound to this @@ -472,7 +475,7 @@ cgDataCon data_con -- The case continuation code is expecting a tagged pointer ; stmtC (CmmAssign nodeReg (tagCons data_con (CmmReg nodeReg))) - ; performReturn emitReturnInstr } + ; performReturn $ emitReturnInstr (Just []) } -- noStmts: Ptr to thing already in Node ; whenC (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index e69db9f61b..cb3a86ef7f 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -149,7 +149,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) - ; performReturn emitReturnInstr } + ; performReturn $ emitReturnInstr (Just [node]) } where -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because @@ -172,7 +172,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args emptyVarSet - performReturn emitReturnInstr + -- ToDo: STG Live -- worried about this + performReturn $ emitReturnInstr (Just []) | ReturnsPrim rep <- result_info = do res <- newTemp (typeCmmType res_ty) @@ -191,7 +192,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg (CmmLocal tag_reg)))) - performReturn emitReturnInstr + -- ToDo: STG Live -- worried about this + performReturn $ emitReturnInstr (Just [node]) where result_info = getPrimOpResultInfo primop diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 8d8b97d76a..09636bc6b2 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -7,15 +7,15 @@ ----------------------------------------------------------------------------- module CgForeignCall ( - cgForeignCall, - emitForeignCall, - emitForeignCall', - shimForeignCallArg, - emitSaveThreadState, -- will be needed by the Cmm parser - emitLoadThreadState, -- ditto - emitCloseNursery, - emitOpenNursery, - ) where + cgForeignCall, + emitForeignCall, + emitForeignCall', + shimForeignCallArg, + emitSaveThreadState, -- will be needed by the Cmm parser + emitLoadThreadState, -- ditto + emitCloseNursery, + emitOpenNursery, + ) where import StgSyn import CgProf @@ -271,7 +271,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff tso_stackobj = closureField oFFSET_StgTSO_stackobj -tso_CCCS = closureField oFFSET_StgTSO_CCCS +tso_CCCS = closureField oFFSET_StgTSO_cccs stack_STACK = closureField oFFSET_StgStack_stack stack_SP = closureField oFFSET_StgStack_sp diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 03b5deb058..dfe146dfc8 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -54,6 +54,7 @@ import Outputable import FastString import Data.List +import Data.Maybe (fromMaybe) \end{code} @@ -273,21 +274,22 @@ an automatic context switch is done. A heap/stack check at a function or thunk entry point. \begin{code} -funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code -funEntryChecks cl_info reg_save_code code - = hpStkCheck cl_info True reg_save_code code +funEntryChecks :: ClosureInfo -> CmmStmts -> Maybe [GlobalReg] -> Code -> Code +funEntryChecks cl_info reg_save_code live code + = hpStkCheck cl_info True reg_save_code live code thunkEntryChecks :: ClosureInfo -> Code -> Code thunkEntryChecks cl_info code - = hpStkCheck cl_info False noStmts code + = hpStkCheck cl_info False noStmts (Just [node]) code hpStkCheck :: ClosureInfo -- Function closure -> Bool -- Is a function? (not a thunk) -> CmmStmts -- Register saves + -> Maybe [GlobalReg] -- Live registers -> Code -> Code -hpStkCheck cl_info is_fun reg_save_code code +hpStkCheck cl_info is_fun reg_save_code live code = getFinalStackHW $ \ spHw -> do { sp <- getRealSp ; let stk_words = spHw - sp @@ -295,17 +297,18 @@ hpStkCheck cl_info is_fun reg_save_code code { -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole codeOnly $ do - { do_checks stk_words hpHw full_save_code rts_label + { do_checks stk_words hpHw full_save_code rts_label full_live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } } where - node_asst + (node_asst, full_live) | nodeMustPointToIt (closureLFInfo cl_info) - = noStmts + = (noStmts, live) | otherwise - = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + ,Just $ node : fromMaybe [] live) -- Strictly speaking, we should tag node here. But if -- node doesn't point to the closure, the code for the closure -- cannot depend on the value of R1 anyway, so we're safe. @@ -349,12 +352,17 @@ altHeapCheck alt_type code { codeOnly $ do { do_checks 0 {- no stack chk -} hpHw noStmts {- nothign to save -} - (rts_label alt_type) + rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } where - rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1"))) + (rts_label, live) = gc_info alt_type + + mkL l = CmmLit . CmmLabel $ mkCmmCodeLabel rtsPackageId (fsLit l) + + gc_info PolyAlt = (mkL "stg_gc_unpt_r1" , Just [node]) + -- Do *not* enter R1 after a heap check in -- a polymorphic case. It might be a function -- and the entry code for a function (currently) @@ -362,22 +370,21 @@ altHeapCheck alt_type code -- -- However R1 is guaranteed to be a pointer - rts_label (AlgAlt _) = stg_gc_enter1 + gc_info (AlgAlt _) = (stg_gc_enter1, Just [node]) -- Enter R1 after the heap check; it's a pointer - rts_label (PrimAlt tc) - = CmmLit $ CmmLabel $ - case primRepToCgRep (tyConPrimRep tc) of - VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs") - FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1") - DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1") - LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1") + gc_info (PrimAlt tc) + = case primRepToCgRep (tyConPrimRep tc) of + VoidArg -> (mkL "stg_gc_noregs", Just []) + FloatArg -> (mkL "stg_gc_f1", Just [FloatReg 1]) + DoubleArg -> (mkL "stg_gc_d1", Just [DoubleReg 1]) + LongArg -> (mkL "stg_gc_l1", Just [LongReg 1]) -- R1 is boxed but unlifted: - PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1") + PtrArg -> (mkL "stg_gc_unpt_r1", Just [node]) -- R1 is unboxed: - NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1") + NonPtrArg -> (mkL "stg_gc_unbx_r1", Just [node]) - rts_label (UbxTupAlt _) = panic "altHeapCheck" + gc_info (UbxTupAlt _) = panic "altHeapCheck" \end{code} @@ -404,7 +411,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code | otherwise = initHeapUsage $ \ hpHw -> do { codeOnly $ do { do_checks 0 {- no stack check -} hpHw - full_fail_code rts_label + full_fail_code rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } @@ -413,6 +420,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! (CmmLit (mkWordCLit liveness)) liveness = mkRegLiveness regs ptrs nptrs + live = Just $ map snd regs rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -434,14 +442,15 @@ again on re-entry because someone else might have stolen the resource in the meantime. \begin{code} -do_checks :: WordOff -- Stack headroom - -> WordOff -- Heap headroom - -> CmmStmts -- Assignments to perform on failure - -> CmmExpr -- Rts address to jump to on failure +do_checks :: WordOff -- Stack headroom + -> WordOff -- Heap headroom + -> CmmStmts -- Assignments to perform on failure + -> CmmExpr -- Rts address to jump to on failure + -> Maybe [GlobalReg] -- Live registers -> Code -do_checks 0 0 _ _ = nopC +do_checks 0 0 _ _ _ = nopC -do_checks _ hp _ _ +do_checks _ hp _ _ _ | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W = sorry (unlines [ "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", @@ -450,21 +459,22 @@ do_checks _ hp _ _ "Suggestion: read data from a file instead of having large static data", "structures in the code."]) -do_checks stk hp reg_save_code rts_lbl +do_checks stk hp reg_save_code rts_lbl live = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) (CmmLit (mkIntCLit (hp*wORD_SIZE))) - (stk /= 0) (hp /= 0) reg_save_code rts_lbl + (stk /= 0) (hp /= 0) reg_save_code rts_lbl live -- The offsets are now in *bytes* -do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code -do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl +do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr + -> Maybe [GlobalReg] -> Code +do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live = do { doGranAllocate hp_expr -- The failure block: this saves the registers and jumps to -- the appropriate RTS stub. ; exit_blk_id <- forkLabelledCode $ do { ; emitStmts reg_save_code - ; stmtC (CmmJump rts_lbl []) } + ; stmtC (CmmJump rts_lbl live) } -- In the case of a heap-check failure, we must also set -- HpAlloc. NB. HpAlloc is *only* set if Hp has been @@ -514,7 +524,8 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl \begin{code} hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code hpChkGen bytes liveness reentry - = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen + = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns + stg_gc_gen (Just activeStgRegs) where assigns = mkStmts [ mk_vanilla_assignment 9 liveness, mk_vanilla_assignment 10 reentry ] @@ -523,12 +534,14 @@ hpChkGen bytes liveness reentry -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code hpChkNodePointsAssignSp0 bytes sp0 - = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1 + = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign + stg_gc_enter1 (Just [node]) where assign = oneStmt (CmmStore (CmmReg spReg) sp0) stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code stkChkGen bytes liveness reentry - = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen + = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns + stg_gc_gen (Just activeStgRegs) where assigns = mkStmts [ mk_vanilla_assignment 9 liveness, mk_vanilla_assignment 10 reentry ] @@ -539,7 +552,8 @@ mk_vanilla_assignment n e stkChkNodePoints :: CmmExpr -> Code stkChkNodePoints bytes - = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1 + = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts + stg_gc_enter1 (Just [node]) stg_gc_gen :: CmmExpr stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index ed5c5261d7..ee5fb594c7 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -232,10 +232,10 @@ emitAlgReturnTarget name branches mb_deflt fam_sz -- global labels, so we can't use them at the 'call site' -------------------------------- -emitReturnInstr :: Code -emitReturnInstr - = do { info_amode <- getSequelAmode - ; stmtC (CmmJump (entryCode info_amode) []) } +emitReturnInstr :: Maybe [GlobalReg] -> Code +emitReturnInstr live + = do { info_amode <- getSequelAmode + ; stmtC (CmmJump (entryCode info_amode) live) } ----------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 6e164ce9ee..f907f85071 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -4,20 +4,19 @@ % \section[CgMonad]{The code generation monad} -See the beginning of the top-level @CodeGen@ module, to see how this -monadic stuff fits into the Big Picture. +See the beginning of the top-level @CodeGen@ module, to see how this monadic +stuff fits into the Big Picture. \begin{code} {-# LANGUAGE BangPatterns #-} module CgMonad ( - Code, - FCode, + Code, FCode, initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs, returnFC, fixC, fixC_, checkedAbsC, stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC, - newUnique, newUniqSupply, + newUnique, newUniqSupply, CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks, getCgStmts', getCgStmts, @@ -35,7 +34,7 @@ module CgMonad ( setEndOfBlockInfo, getEndOfBlockInfo, setSRT, getSRT, - setSRTLabel, getSRTLabel, + setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, StackUsage(..), HeapUsage(..), @@ -48,10 +47,11 @@ module CgMonad ( Sequel(..), - -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, getDynFlags, getThisPackage, + -- ideally we wouldn't export these, but some other modules access + -- internal state + getState, setState, getInfoDown, getDynFlags, getThisPackage, - -- more localised access to monad state + -- more localised access to monad state getStkUsage, setStkUsage, getBinds, setBinds, getStaticBinds, @@ -92,82 +92,86 @@ infixr 9 `thenFC` %* * %************************************************************************ -This monadery has some information that it only passes {\em -downwards}, as well as some ``state'' which is modified as we go -along. +This monadery has some information that it only passes {\em downwards}, as well +as some ``state'' which is modified as we go along. \begin{code} -data CgInfoDownwards -- information only passed *downwards* by the monad + +-- | State only passed *downwards* by the monad +data CgInfoDownwards = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- label of the current SRT - cgd_srt :: SRT, -- the current SRT - cgd_ticky :: CLabel, -- current destination for ticky counts - cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: + cgd_dflags :: DynFlags, -- current flag settings + cgd_mod :: Module, -- Module being compiled + cgd_statics :: CgBindings, -- [Id -> info] : static environment + cgd_srt_lbl :: CLabel, -- label of the current SRT + cgd_srt :: SRT, -- the current SRT + cgd_ticky :: CLabel, -- current destination for ticky counts + cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: } +-- | Setup initial @CgInfoDownwards@ for the code gen initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_srt = error "initC: srt", - cgd_ticky = mkTopTickyCtrLabel, - cgd_eob = initEobInfo } + = MkCgInfoDown { cgd_dflags = dflags, + cgd_mod = mod, + cgd_statics = emptyVarEnv, + cgd_srt_lbl = error "initC: srt_lbl", + cgd_srt = error "initC: srt", + cgd_ticky = mkTopTickyCtrLabel, + cgd_eob = initEobInfo + } +-- | State passed around and modified during code generation data CgState = MkCgState { - cgs_stmts :: OrdList CgStmt, -- Current proc - cgs_tops :: OrdList CmmDecl, - -- Other procedures and data blocks in this compilation unit - -- Both the latter two are ordered only so that we can - -- reduce forward references, when it's easy to do so - - cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment - -- Bindings for top-level things are given in - -- the info-down part - + cgs_stmts :: OrdList CgStmt, + -- Current proc + cgs_tops :: OrdList CmmDecl, + -- Other procedures and data blocks in this compilation unit + -- Both the latter two are ordered only so that we can + -- reduce forward references, when it's easy to do so + + cgs_binds :: CgBindings, + -- [Id -> info] : *local* bindings environment Bindings for + -- top-level things are given in the info-down part + cgs_stk_usg :: StackUsage, cgs_hp_usg :: HeapUsage, - - cgs_uniqs :: UniqSupply } + cgs_uniqs :: UniqSupply + } +-- | Setup initial @CgState@ for the code gen initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = nilOL, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_stk_usg = initStkUsage, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } -\end{code} - -@EndOfBlockInfo@ tells what to do at the end of this block of code or, -if the expression is a @case@, what to do at the end of each -alternative. + = MkCgState { cgs_stmts = nilOL, + cgs_tops = nilOL, + cgs_binds = emptyVarEnv, + cgs_stk_usg = initStkUsage, + cgs_hp_usg = initHpUsage, + cgs_uniqs = uniqs + } -\begin{code} +-- | @EndOfBlockInfo@ tells what to do at the end of this block of code or, if +-- the expression is a @case@, what to do at the end of each alternative. data EndOfBlockInfo = EndOfBlockInfo - VirtualSpOffset -- Args Sp: trim the stack to this point at a - -- return; push arguments starting just - -- above this point on a tail call. - - -- This is therefore the stk ptr as seen - -- by a case alternative. + VirtualSpOffset -- Args Sp: trim the stack to this point at a + -- return; push arguments starting just + -- above this point on a tail call. + -- + -- This is therefore the stk ptr as seen + -- by a case alternative. Sequel +-- | Standard @EndOfBlockInfo@ where the continuation is on the stack initEobInfo :: EndOfBlockInfo initEobInfo = EndOfBlockInfo 0 OnStack -\end{code} -Any addressing modes inside @Sequel@ must be ``robust,'' in the sense -that it must survive stack pointer adjustments at the end of the -block. - -\begin{code} +-- | @Sequel@ is a representation of the next continuation to jump to +-- after the current function. +-- +-- Any addressing modes inside @Sequel@ must be ``robust,'' in the sense +-- that it must survive stack pointer adjustments at the end of the block. data Sequel = OnStack -- Continuation is on the stack @@ -178,9 +182,9 @@ data Sequel Id -- The case binder, only used to see if it's dead type SemiTaggingStuff - = Maybe -- Maybe we don't have any semi-tagging stuff... - ([(ConTagZ, CmmLit)], -- Alternatives - CmmLit) -- Default (will be a can't happen RTS label if can't happen) + = Maybe -- Maybe we don't have any semi-tagging stuff... + ([(ConTagZ, CmmLit)], -- Alternatives + CmmLit) -- Default (will be a can't happen RTS label if can't happen) -- The case branch is executed only from a successful semitagging -- venture, when a case has looked at a variable, found that it's @@ -195,9 +199,9 @@ type SemiTaggingStuff %************************************************************************ The CgStmts type is what the code generator outputs: it is a tree of -statements, including in-line labels. The job of flattenCgStmts is to -turn this into a list of basic blocks, each of which ends in a jump -statement (either a local branch or a non-local jump). +statements, including in-line labels. The job of flattenCgStmts is to turn +this into a list of basic blocks, each of which ends in a jump statement +(either a local branch or a non-local jump). \begin{code} type CgStmts = OrdList CgStmt @@ -208,7 +212,7 @@ data CgStmt | CgFork BlockId CgStmts flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock] -flattenCgStmts id stmts = +flattenCgStmts id stmts = case flatten (fromOL stmts) of ([],blocks) -> blocks (block,blocks) -> BasicBlock id block : blocks @@ -231,15 +235,15 @@ flattenCgStmts id stmts = [CgLabel id] -> ( [stmt], [BasicBlock id [CmmBranch id]]) (CgLabel id : stmts) -> ( [stmt], BasicBlock id block : blocks ) where (block,blocks) = flatten stmts - (CgFork fork_id stmts : ss) -> + (CgFork fork_id stmts : ss) -> flatten (CgFork fork_id stmts : CgStmt stmt : ss) (CgStmt {} : _) -> panic "CgStmt not seen as ordinary" - flatten (s:ss) = + flatten (s:ss) = case s of CgStmt stmt -> (stmt:block,blocks) CgLabel id -> ([CmmBranch id],BasicBlock id block:blocks) - CgFork fork_id stmts -> + CgFork fork_id stmts -> (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks) where (fork_block, fork_blocks) = flatten (fromOL stmts) where (block,blocks) = flatten ss @@ -248,7 +252,7 @@ isJump :: CmmStmt -> Bool isJump (CmmJump _ _) = True isJump (CmmBranch _ ) = True isJump (CmmSwitch _ _) = True -isJump (CmmReturn _ ) = True +isJump (CmmReturn ) = True isJump _ = False isOrdinaryStmt :: CgStmt -> Bool @@ -263,10 +267,15 @@ isOrdinaryStmt _ = False %************************************************************************ \begin{code} -type VirtualHpOffset = WordOff -- Both are in -type VirtualSpOffset = WordOff -- units of words +type VirtualHpOffset = WordOff -- Both are in +type VirtualSpOffset = WordOff -- units of words -data StackUsage +-- | Stack usage information during code generation. +-- +-- INVARIANT: The environment contains no Stable references to +-- stack slots below (lower offset) frameSp +-- It can contain volatile references to this area though. +data StackUsage = StackUsage { virtSp :: VirtualSpOffset, -- Virtual offset of topmost allocated slot @@ -277,83 +286,83 @@ data StackUsage -- all the stack from frameSp downwards -- INVARIANT: less than or equal to virtSp - freeStk :: [VirtualSpOffset], + freeStk :: [VirtualSpOffset], -- List of free slots, in *increasing* order -- INVARIANT: all <= virtSp - -- All slots <= virtSp are taken except these ones + -- All slots <= virtSp are taken except these ones - realSp :: VirtualSpOffset, + realSp :: VirtualSpOffset, -- Virtual offset of real stack pointer register hwSp :: VirtualSpOffset - } -- Highest value ever taken by virtSp - --- INVARIANT: The environment contains no Stable references to --- stack slots below (lower offset) frameSp --- It can contain volatile references to this area though. - -data HeapUsage = - HeapUsage { - virtHp :: VirtualHpOffset, -- Virtual offset of highest-allocated word - realHp :: VirtualHpOffset -- realHp: Virtual offset of real heap ptr + } -- Highest value ever taken by virtSp + +-- | Heap usage information during code generation. +-- +-- virtHp keeps track of the next location to allocate an object at. realHp +-- keeps track of what the Hp STG register actually points to. The reason these +-- aren't always the same is that we want to be able to move the realHp in one +-- go when allocating numerous objects to save having to bump it each time. +-- virtHp we do bump each time but it doesn't create corresponding inefficient +-- machine code. +data HeapUsage + = HeapUsage { + virtHp :: VirtualHpOffset, -- Virtual offset of highest allocated word + realHp :: VirtualHpOffset -- Virtual offset of real heap ptr } -\end{code} - -virtHp keeps track of the next location to allocate an object at. realHp keeps -track of what the Hp STG register actually points to. The reason these aren't -always the same is that we want to be able to move the realHp in one go when -allocating numerous objects to save having to bump it each time. virtHp we do -bump each time but it doesn't create corresponding inefficient machine code. -\begin{code} +-- | Return the heap usage high water mark heapHWM :: HeapUsage -> VirtualHpOffset heapHWM = virtHp -\end{code} -Initialisation. -\begin{code} +-- | Initial stack usage initStkUsage :: StackUsage -initStkUsage = StackUsage { - virtSp = 0, - frameSp = 0, - freeStk = [], - realSp = 0, - hwSp = 0 - } - -initHpUsage :: HeapUsage -initHpUsage = HeapUsage { - virtHp = 0, - realHp = 0 - } +initStkUsage + = StackUsage { + virtSp = 0, + frameSp = 0, + freeStk = [], + realSp = 0, + hwSp = 0 + } + +-- | Initial heap usage +initHpUsage :: HeapUsage +initHpUsage + = HeapUsage { + virtHp = 0, + realHp = 0 + } -- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to -- be the max of the high water marks of $arg1$ and $arg2$. stateIncUsage :: CgState -> CgState -> CgState stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg }) - = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg, - cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg } - `addCodeBlocksFrom` s2 - + = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg, + cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp stk_usg } + `addCodeBlocksFrom` s2 + +-- | Similar to @stateIncUsafe@ but we don't max the heap high-watermark +-- because @stateIncUsageEval@ is used only in forkEval, which in turn is only +-- used for blocks of code which do their own heap-check. stateIncUsageEval :: CgState -> CgState -> CgState stateIncUsageEval s1 s2 - = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) } - `addCodeBlocksFrom` s2 - -- We don't max the heap high-watermark because stateIncUsageEval is - -- used only in forkEval, which in turn is only used for blocks of code - -- which do their own heap-check. + = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) } + `addCodeBlocksFrom` s2 +-- | Add code blocks from the latter to the former +-- (The cgs_stmts will often be empty, but not always; see @codeOnly@) addCodeBlocksFrom :: CgState -> CgState -> CgState --- Add code blocks from the latter to the former --- (The cgs_stmts will often be empty, but not always; see codeOnly) s1 `addCodeBlocksFrom` s2 = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2, cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 } +-- | Set @HeapUsage@ virtHp to max of current or $arg2$. maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw } +-- | Set @StackUsage@ hwSp to max of current or $arg2$. maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw } \end{code} @@ -369,15 +378,14 @@ newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState)) type Code = FCode () instance Monad FCode where - (>>=) = thenFC + (>>=) = thenFC return = returnFC {-# INLINE thenC #-} {-# INLINE thenFC #-} {-# INLINE returnFC #-} -\end{code} -The Abstract~C is not in the environment so as to improve strictness. +<<<<<<< HEAD \begin{code} initC :: IO CgState initC = do { uniqs <- mkSplitUniqSupply 'c' @@ -385,35 +393,43 @@ initC = do { uniqs <- mkSplitUniqSupply 'c' runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState) runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st +||||||| merged common ancestors +\begin{code} +initC :: DynFlags -> Module -> FCode a -> IO a + +initC dflags mod (FCode code) + = do { uniqs <- mkSplitUniqSupply 'c' + ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of + (res, _) -> return res + } +======= +initC :: DynFlags -> Module -> FCode a -> IO a +initC dflags mod (FCode code) = do + uniqs <- mkSplitUniqSupply 'c' + case code (initCgInfoDown dflags mod) (initCgState uniqs) of + (res, _) -> return res +>>>>>>> origin/master returnFC :: a -> FCode a -returnFC val = FCode (\_ state -> (val, state)) -\end{code} +returnFC val = FCode $ \_ state -> (val, state) -\begin{code} thenC :: Code -> FCode a -> FCode a -thenC (FCode m) (FCode k) = - FCode (\info_down state -> let (_,new_state) = m info_down state in - k info_down new_state) +thenC (FCode m) (FCode k) = FCode $ \info_down state -> + let (_,new_state) = m info_down state + in k info_down new_state listCs :: [Code] -> Code -listCs [] = return () -listCs (fc:fcs) = do - fc - listCs fcs - +listCs [] = return () +listCs (fc:fcs) = fc >> listCs fcs + mapCs :: (a -> Code) -> [a] -> Code mapCs = mapM_ thenFC :: FCode a -> (a -> FCode c) -> FCode c -thenFC (FCode m) k = FCode ( - \info_down state -> - let - (m_result, new_state) = m info_down state - (FCode kcode) = k m_result - in - kcode info_down new_state - ) +thenFC (FCode m) k = FCode $ \info_down state -> + let (m_result, new_state) = m info_down state + (FCode kcode) = k m_result + in kcode info_down new_state listFCs :: [FCode a] -> FCode [a] listFCs = sequence @@ -423,11 +439,10 @@ mapFCs = mapM -- | Knot-tying combinator for @FCode@ fixC :: (a -> FCode a) -> FCode a -fixC fcode = FCode $ - \info_down state -> - let FCode fc = fcode v - result@(v,_) = fc info_down state - in result +fixC fcode = FCode $ \info_down state -> + let FCode fc = fcode v + result@(v,_) = fc info_down state + in result -- | Knot-tying combinator that throws result away fixC_ :: (a -> FCode a) -> FCode () @@ -442,241 +457,225 @@ fixC_ fcode = fixC fcode >> return () \begin{code} getState :: FCode CgState -getState = FCode $ \_ state -> (state,state) +getState = FCode $ \_ state -> (state, state) setState :: CgState -> FCode () -setState state = FCode $ \_ _ -> ((),state) +setState state = FCode $ \_ _ -> ((), state) getStkUsage :: FCode StackUsage getStkUsage = do - state <- getState - return $ cgs_stk_usg state + state <- getState + return $ cgs_stk_usg state setStkUsage :: StackUsage -> Code setStkUsage new_stk_usg = do - state <- getState - setState $ state {cgs_stk_usg = new_stk_usg} + state <- getState + setState $ state {cgs_stk_usg = new_stk_usg} getHpUsage :: FCode HeapUsage getHpUsage = do - state <- getState - return $ cgs_hp_usg state - + state <- getState + return $ cgs_hp_usg state + setHpUsage :: HeapUsage -> Code setHpUsage new_hp_usg = do - state <- getState - setState $ state {cgs_hp_usg = new_hp_usg} + state <- getState + setState $ state {cgs_hp_usg = new_hp_usg} getBinds :: FCode CgBindings getBinds = do - state <- getState - return $ cgs_binds state - + state <- getState + return $ cgs_binds state + setBinds :: CgBindings -> FCode () setBinds new_binds = do - state <- getState - setState $ state {cgs_binds = new_binds} + state <- getState + setState $ state {cgs_binds = new_binds} getStaticBinds :: FCode CgBindings getStaticBinds = do - info <- getInfoDown - return (cgd_statics info) + info <- getInfoDown + return (cgd_statics info) withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> - let (retval, state2) = fcode info_down newstate in ((retval,state2), state) +withState (FCode fcode) newstate = FCode $ \info_down state -> + let (retval, state2) = fcode info_down newstate + in ((retval, state2), state) newUniqSupply :: FCode UniqSupply newUniqSupply = do - state <- getState - let (us1, us2) = splitUniqSupply (cgs_uniqs state) - setState $ state { cgs_uniqs = us1 } - return us2 + state <- getState + let (us1, us2) = splitUniqSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us1 } + return us2 newUnique :: FCode Unique newUnique = do - us <- newUniqSupply - return (uniqFromSupply us) + us <- newUniqSupply + return (uniqFromSupply us) getInfoDown :: FCode CgInfoDownwards -getInfoDown = FCode $ \info_down state -> (info_down,state) +getInfoDown = FCode $ \info_down state -> (info_down, state) -getDynFlags :: FCode DynFlags -getDynFlags = liftM cgd_dflags getInfoDown +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state +withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) doFCode (FCode fcode) info_down state = fcode info_down state \end{code} - %************************************************************************ %* * Forking %* * %************************************************************************ -@forkClosureBody@ takes a code, $c$, and compiles it in a completely -fresh environment, except that: - - compilation info and statics are passed in unchanged. -The current environment is passed on completely unaltered, except that -abstract C from the fork is incorporated. - -@forkProc@ takes a code and compiles it in the current environment, -returning the basic blocks thus constructed. The current environment -is passed on completely unchanged. It is pretty similar to -@getBlocks@, except that the latter does affect the environment. - -@forkStatics@ $fc$ compiles $fc$ in an environment whose statics come -from the current bindings, but which is otherwise freshly initialised. -The Abstract~C returned is attached to the current state, but the -bindings and usage information is otherwise unchanged. - \begin{code} + +-- | Takes code and compiles it in a completely fresh environment, except that +-- compilation info and statics are passed in unchanged. The current +-- environment is passed on completely unaltered, except that the Cmm code +-- from the fork is incorporated. forkClosureBody :: Code -> Code -forkClosureBody body_code - = do { info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_eob = initEobInfo } - ((),fork_state) = doFCode body_code body_info_down - (initCgState us) - ; ASSERT( isNilOL (cgs_stmts fork_state) ) - setState $ state `addCodeBlocksFrom` fork_state } - +forkClosureBody body_code = do + info <- getInfoDown + us <- newUniqSupply + state <- getState + let body_info_down = info { cgd_eob = initEobInfo } + ((), fork_state) = doFCode body_code body_info_down (initCgState us) + + ASSERT( isNilOL (cgs_stmts fork_state) ) + setState $ state `addCodeBlocksFrom` fork_state + +-- | @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come +-- from the current bindings, but which is otherwise freshly initialised. +-- The Cmm returned is attached to the current state, but the bindings and +-- usage information is otherwise unchanged. forkStatics :: FCode a -> FCode a -forkStatics body_code - = do { info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state, - cgd_eob = initEobInfo } - (result, fork_state_out) = doFCode body_code rhs_info_down - (initCgState us) - ; ASSERT( isNilOL (cgs_stmts fork_state_out) ) - setState (state `addCodeBlocksFrom` fork_state_out) - ; return result } - +forkStatics body_code = do + info <- getInfoDown + us <- newUniqSupply + state <- getState + let rhs_info_down = info { cgd_statics = cgs_binds state, + cgd_eob = initEobInfo } + (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) + + ASSERT( isNilOL (cgs_stmts fork_state_out) ) + setState (state `addCodeBlocksFrom` fork_state_out) + return result + +-- | @forkProc@ takes a code and compiles it in the current environment, +-- returning the basic blocks thus constructed. The current environment is +-- passed on completely unchanged. It is pretty similar to @getBlocks@, except +-- that the latter does affect the environment. forkProc :: Code -> FCode CgStmts -forkProc body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let fork_state_in = (initCgState us) - { cgs_binds = cgs_binds state, - cgs_stk_usg = cgs_stk_usg state, - cgs_hp_usg = cgs_hp_usg state } - -- ToDo: is the hp usage necesary? - (code_blks, fork_state_out) = doFCode (getCgStmts body_code) - info_down fork_state_in - ; setState $ state `stateIncUsageEval` fork_state_out - ; return code_blks } +forkProc body_code = do + info <- getInfoDown + us <- newUniqSupply + state <- getState + let fork_state_in = (initCgState us) + { cgs_binds = cgs_binds state, + cgs_stk_usg = cgs_stk_usg state, + cgs_hp_usg = cgs_hp_usg state } + (code_blks, fork_state_out) = doFCode (getCgStmts body_code) + info fork_state_in + setState $ state `stateIncUsageEval` fork_state_out + return code_blks -- Emit any code from the inner thing into the outer thing -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly :: Code -> Code -codeOnly body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, - cgs_stk_usg = cgs_stk_usg state, - cgs_hp_usg = cgs_hp_usg state } - ((), fork_state_out) = doFCode body_code info_down fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out } -\end{code} - -@forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and -an fcode for the default case $d$, and compiles each in the current -environment. The current environment is passed on unmodified, except -that - - the worst stack high-water mark is incorporated - - the virtual Hp is moved on to the worst virtual Hp for the branches - -\begin{code} +codeOnly body_code = do + info <- getInfoDown + us <- newUniqSupply + state <- getState + let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, + cgs_stk_usg = cgs_stk_usg state, + cgs_hp_usg = cgs_hp_usg state } + ((), fork_state_out) = doFCode body_code info fork_state_in + setState $ state `addCodeBlocksFrom` fork_state_out + +-- | @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and an +-- an fcode for the default case $d$, and compiles each in the current +-- environment. The current environment is passed on unmodified, except that: +-- * the worst stack high-water mark is incorporated +-- * the virtual Hp is moved on to the worst virtual Hp for the branches forkAlts :: [FCode a] -> FCode [a] - -forkAlts branch_fcodes - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let compile us branch - = (us2, doFCode branch info_down branch_state) - where - (us1,us2) = splitUniqSupply us - branch_state = (initCgState us1) { - cgs_binds = cgs_binds state, - cgs_stk_usg = cgs_stk_usg state, - cgs_hp_usg = cgs_hp_usg state } - - (_us, results) = mapAccumL compile us branch_fcodes - (branch_results, branch_out_states) = unzip results - ; setState $ foldl stateIncUsage state branch_out_states - -- NB foldl. state is the *left* argument to stateIncUsage - ; return branch_results } -\end{code} - -@forkEval@ takes two blocks of code. - - - The first meddles with the environment to set it up as expected by - the alternatives of a @case@ which does an eval (or gc-possible primop). - - The second block is the code for the alternatives. - (plus info for semi-tagging purposes) - -@forkEval@ picks up the virtual stack pointer and returns a suitable -@EndOfBlockInfo@ for the caller to use, together with whatever value -is returned by the second block. - -It uses @initEnvForAlternatives@ to initialise the environment, and -@stateIncUsageAlt@ to incorporate usage; the latter ignores the heap -usage. - -\begin{code} -forkEval :: EndOfBlockInfo -- For the body - -> Code -- Code to set environment - -> FCode Sequel -- Semi-tagging info to store - -> FCode EndOfBlockInfo -- The new end of block info - -forkEval body_eob_info env_code body_code - = do { (v, sequel) <- forkEvalHelp body_eob_info env_code body_code - ; returnFC (EndOfBlockInfo v sequel) } - +forkAlts branch_fcodes = do + info <- getInfoDown + us <- newUniqSupply + state <- getState + let compile us branch = (us2, doFCode branch info branch_state) + where + (us1,us2) = splitUniqSupply us + branch_state = (initCgState us1) { + cgs_binds = cgs_binds state, + cgs_stk_usg = cgs_stk_usg state, + cgs_hp_usg = cgs_hp_usg state } + (_us, results) = mapAccumL compile us branch_fcodes + (branch_results, branch_out_states) = unzip results + -- NB foldl. state is the *left* argument to stateIncUsage + setState $ foldl stateIncUsage state branch_out_states + return branch_results + +-- | @forkEval@ takes two blocks of code. +-- +-- * The first meddles with the environment to set it up as expected by +-- the alternatives of a @case@ which does an eval (or gc-possible primop). +-- * The second block is the code for the alternatives. +-- (plus info for semi-tagging purposes) +-- +-- @forkEval@ picks up the virtual stack pointer and returns a suitable +-- @EndOfBlockInfo@ for the caller to use, together with whatever value +-- is returned by the second block. +-- +-- It uses @initEnvForAlternatives@ to initialise the environment, and +-- @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap usage. +forkEval :: EndOfBlockInfo -- For the body + -> Code -- Code to set environment + -> FCode Sequel -- Semi-tagging info to store + -> FCode EndOfBlockInfo -- The new end of block info +forkEval body_eob_info env_code body_code = do + (v, sequel) <- forkEvalHelp body_eob_info env_code body_code + returnFC (EndOfBlockInfo v sequel) + +-- A disturbingly complicated function forkEvalHelp :: EndOfBlockInfo -- For the body -> Code -- Code to set environment -> FCode a -- The code to do after the eval -> FCode (VirtualSpOffset, -- Sp a) -- Result of the FCode - -- A disturbingly complicated function -forkEvalHelp body_eob_info env_code body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let { info_down_for_body = info_down {cgd_eob = body_eob_info} - ; (_, env_state) = doFCode env_code info_down_for_body - (state {cgs_uniqs = us}) - ; state_for_body = (initCgState (cgs_uniqs env_state)) - { cgs_binds = binds_for_body, - cgs_stk_usg = stk_usg_for_body } - ; binds_for_body = nukeVolatileBinds (cgs_binds env_state) - ; stk_usg_from_env = cgs_stk_usg env_state - ; virtSp_from_env = virtSp stk_usg_from_env - ; stk_usg_for_body = stk_usg_from_env {realSp = virtSp_from_env, - hwSp = virtSp_from_env} - ; (value_returned, state_at_end_return) - = doFCode body_code info_down_for_body state_for_body - } - ; ASSERT( isNilOL (cgs_stmts state_at_end_return) ) - -- The code coming back should consist only of nested declarations, - -- notably of the return vector! - setState $ state `stateIncUsageEval` state_at_end_return - ; return (virtSp_from_env, value_returned) } - +forkEvalHelp body_eob_info env_code body_code = do + info <- getInfoDown + us <- newUniqSupply + state <- getState + + let info_body = info { cgd_eob = body_eob_info } + (_, env_state) = doFCode env_code info_body + (state {cgs_uniqs = us}) + state_for_body = (initCgState (cgs_uniqs env_state)) + { cgs_binds = binds_for_body, + cgs_stk_usg = stk_usg_for_body } + binds_for_body = nukeVolatileBinds (cgs_binds env_state) + stk_usg_from_env = cgs_stk_usg env_state + virtSp_from_env = virtSp stk_usg_from_env + stk_usg_for_body = stk_usg_from_env { realSp = virtSp_from_env, + hwSp = virtSp_from_env } + (value_returned, state_at_end_return) + = doFCode body_code info_body state_for_body + + -- The code coming back should consist only of nested declarations, + -- notably of the return vector! + ASSERT( isNilOL (cgs_stmts state_at_end_return) ) + setState $ state `stateIncUsageEval` state_at_end_return + return (virtSp_from_env, value_returned) -- ---------------------------------------------------------------------------- -- Combinators for emitting code @@ -697,20 +696,20 @@ labelC :: BlockId -> Code labelC id = emitCgStmt (CgLabel id) newLabelC :: FCode BlockId -newLabelC = do { u <- newUnique - ; return $ mkBlockId u } +newLabelC = do + u <- newUnique + return $ mkBlockId u -- Emit code, eliminating no-ops checkedAbsC :: CmmStmt -> Code -checkedAbsC stmt = emitStmts (if isNopStmt stmt then nilOL - else unitOL stmt) +checkedAbsC stmt = emitStmts $ if isNopStmt stmt then nilOL else unitOL stmt stmtsC :: [CmmStmt] -> Code -stmtsC stmts = emitStmts (toOL stmts) +stmtsC stmts = emitStmts $ toOL stmts -- Emit code; no no-op checking emitStmts :: CmmStmts -> Code -emitStmts stmts = emitCgStmts (fmap CgStmt stmts) +emitStmts stmts = emitCgStmts $ fmap CgStmt stmts -- forkLabelledCode is for emitting a chunk of code with a label, outside -- of the current instruction stream. @@ -718,40 +717,64 @@ forkLabelledCode :: Code -> FCode BlockId forkLabelledCode code = getCgStmts code >>= forkCgStmts emitCgStmt :: CgStmt -> Code -emitCgStmt stmt - = do { state <- getState - ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } - } +emitCgStmt stmt = do + state <- getState + setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } emitDecl :: CmmDecl -> Code -emitDecl decl - = do { state <- getState - ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } +emitDecl decl = do + state <- getState + setState $ state { cgs_tops = cgs_tops state `snocOL` decl } +<<<<<<< HEAD emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code emitProc info lbl [] blocks = do { let proc_block = CmmProc info lbl (ListGraph blocks) ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } +||||||| merged common ancestors +emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code +emitProc info lbl [] blocks + = do { let proc_block = CmmProc info lbl (ListGraph blocks) + ; state <- getState + ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } +======= +emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code +emitProc info lbl [] blocks = do + let proc_block = CmmProc info lbl (ListGraph blocks) + state <- getState + setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } +>>>>>>> origin/master emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args" -- Emit a procedure whose body is the specified code; no info table emitSimpleProc :: CLabel -> Code -> Code +<<<<<<< HEAD emitSimpleProc lbl code = do { stmts <- getCgStmts code ; blks <- cgStmtsToBlocks stmts ; emitProc CmmNonInfoTable lbl [] blks } +||||||| merged common ancestors +emitSimpleProc lbl code + = do { stmts <- getCgStmts code + ; blks <- cgStmtsToBlocks stmts + ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks } +======= +emitSimpleProc lbl code = do + stmts <- getCgStmts code + blks <- cgStmtsToBlocks stmts + emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks +>>>>>>> origin/master -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) getCmm :: Code -> FCode CmmGroup -getCmm code - = do { state1 <- getState - ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) - ; setState $ state2 { cgs_tops = cgs_tops state1 } - ; return (fromOL (cgs_tops state2)) - } +getCmm code = do + state1 <- getState + ((), state2) <- withState code (state1 { cgs_tops = nilOL }) + setState $ state2 { cgs_tops = cgs_tops state1 } + return (fromOL (cgs_tops state2)) -- ---------------------------------------------------------------------------- -- CgStmts @@ -759,38 +782,37 @@ getCmm code -- These functions deal in terms of CgStmts, which is an abstract type -- representing the code in the current proc. - -- emit CgStmts into the current instruction stream emitCgStmts :: CgStmts -> Code -emitCgStmts stmts - = do { state <- getState - ; setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } } +emitCgStmts stmts = do + state <- getState + setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts } -- emit CgStmts outside the current instruction stream, and return a label forkCgStmts :: CgStmts -> FCode BlockId -forkCgStmts stmts - = do { id <- newLabelC - ; emitCgStmt (CgFork id stmts) - ; return id - } +forkCgStmts stmts = do + id <- newLabelC + emitCgStmt (CgFork id stmts) + return id -- turn CgStmts into [CmmBasicBlock], for making a new proc. cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock] -cgStmtsToBlocks stmts - = do { id <- newLabelC - ; return (flattenCgStmts id stmts) - } +cgStmtsToBlocks stmts = do + id <- newLabelC + return (flattenCgStmts id stmts) -- collect the code emitted by an FCode computation getCgStmts' :: FCode a -> FCode (a, CgStmts) -getCgStmts' fcode - = do { state1 <- getState - ; (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL }) - ; setState $ state2 { cgs_stmts = cgs_stmts state1 } - ; return (a, cgs_stmts state2) } +getCgStmts' fcode = do + state1 <- getState + (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL }) + setState $ state2 { cgs_stmts = cgs_stmts state1 } + return (a, cgs_stmts state2) getCgStmts :: FCode a -> FCode CgStmts -getCgStmts fcode = do { (_,stmts) <- getCgStmts' fcode; return stmts } +getCgStmts fcode = do + (_,stmts) <- getCgStmts' fcode + return stmts -- Simple ways to construct CgStmts: noCgStmts :: CgStmts @@ -806,56 +828,60 @@ consCgStmt stmt stmts = CgStmt stmt `consOL` stmts -- Get the current module name getModuleName :: FCode Module -getModuleName = do { info <- getInfoDown; return (cgd_mod info) } +getModuleName = do + info <- getInfoDown + return (cgd_mod info) -- ---------------------------------------------------------------------------- -- Get/set the end-of-block info setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code setEndOfBlockInfo eob_info code = do - info <- getInfoDown - withInfoDown code (info {cgd_eob = eob_info}) + info <- getInfoDown + withInfoDown code (info {cgd_eob = eob_info}) getEndOfBlockInfo :: FCode EndOfBlockInfo getEndOfBlockInfo = do - info <- getInfoDown - return (cgd_eob info) + info <- getInfoDown + return (cgd_eob info) -- ---------------------------------------------------------------------------- -- Get/set the current SRT label -- There is just one SRT for each top level binding; all the nested --- bindings use sub-sections of this SRT. The label is passed down to +-- bindings use sub-sections of this SRT. The label is passed down to -- the nested bindings via the monad. getSRTLabel :: FCode CLabel -- Used only by cgPanic -getSRTLabel = do info <- getInfoDown - return (cgd_srt_lbl info) +getSRTLabel = do + info <- getInfoDown + return (cgd_srt_lbl info) setSRTLabel :: CLabel -> FCode a -> FCode a -setSRTLabel srt_lbl code - = do info <- getInfoDown - withInfoDown code (info { cgd_srt_lbl = srt_lbl}) +setSRTLabel srt_lbl code = do + info <- getInfoDown + withInfoDown code (info { cgd_srt_lbl = srt_lbl}) getSRT :: FCode SRT -getSRT = do info <- getInfoDown - return (cgd_srt info) +getSRT = do + info <- getInfoDown + return (cgd_srt info) setSRT :: SRT -> FCode a -> FCode a -setSRT srt code - = do info <- getInfoDown - withInfoDown code (info { cgd_srt = srt}) +setSRT srt code = do + info <- getInfoDown + withInfoDown code (info { cgd_srt = srt}) -- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label getTickyCtrLabel :: FCode CLabel getTickyCtrLabel = do - info <- getInfoDown - return (cgd_ticky info) + info <- getInfoDown + return (cgd_ticky info) setTickyCtrLabel :: CLabel -> Code -> Code setTickyCtrLabel ticky code = do - info <- getInfoDown - withInfoDown code (info {cgd_ticky = ticky}) + info <- getInfoDown + withInfoDown code (info {cgd_ticky = ticky}) \end{code} diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 3b11054efe..b0865d69d9 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -6,16 +6,9 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CgPrimOp ( - cgPrimOp - ) where + cgPrimOp + ) where import BasicTypes import ForeignCall @@ -43,44 +36,44 @@ import StaticFlags -- --------------------------------------------------------------------------- -- Code generation for PrimOps -cgPrimOp :: [CmmFormal] -- where to put the results - -> PrimOp -- the op - -> [StgArg] -- arguments - -> StgLiveVars -- live vars, in case we need to save them - -> Code +cgPrimOp :: [CmmFormal] -- where to put the results + -> PrimOp -- the op + -> [StgArg] -- arguments + -> StgLiveVars -- live vars, in case we need to save them + -> Code cgPrimOp results op args live = do arg_exprs <- getArgAmodes args - let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ] + let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ] emitPrimOp results op non_void_args live -emitPrimOp :: [CmmFormal] -- where to put the results - -> PrimOp -- the op - -> [CmmExpr] -- arguments - -> StgLiveVars -- live vars, in case we need to save them - -> Code +emitPrimOp :: [CmmFormal] -- where to put the results + -> PrimOp -- the op + -> [CmmExpr] -- arguments + -> StgLiveVars -- live vars, in case we need to save them + -> Code -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _ -{- +{- With some bit-twiddling, we can define int{Add,Sub}Czh portably in C, and without needing any comparisons. This may not be the fastest way to do it - if you have better code, please send it! --SDM - + Return : r = a + b, c = 0 if no overflow, 1 on overflow. - - We currently don't make use of the r value if c is != 0 (i.e. + + We currently don't make use of the r value if c is != 0 (i.e. overflow), we just convert to big integers and try again. This could be improved by making r and c the correct values for - plugging into a new J#. - - { r = ((I_)(a)) + ((I_)(b)); \ - c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ - } + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } Wading through the mass of bracketry, it seems to reduce to: c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) @@ -88,22 +81,22 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _ = stmtsC [ CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] - ], - CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) - ] + CmmMachOp mo_wordUShr [ + CmmMachOp mo_wordAnd [ + CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + ], + CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + ] ] emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ {- Similarly: - #define subIntCzh(r,c,a,b) \ - { r = ((I_)(a)) - ((I_)(b)); \ - c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ - >> (BITS_IN (I_) - 1); \ + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ } c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) @@ -111,27 +104,27 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ = stmtsC [ CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] - ], - CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) - ] + CmmMachOp mo_wordUShr [ + CmmMachOp mo_wordAnd [ + CmmMachOp mo_wordXor [aa,bb], + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + ], + CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + ] ] emitPrimOp [res] ParOp [arg] live = do - -- for now, just implement this in a C function - -- later, we might want to inline it. + -- for now, just implement this in a C function + -- later, we might want to inline it. vols <- getVolatileRegs live emitForeignCall' PlayRisky - [CmmHinted res NoHint] - (CmmCallee newspark CCallConv) - [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) - , (CmmHinted arg AddrHint) ] - (Just vols) + [CmmHinted res NoHint] + (CmmCallee newspark CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) + , (CmmHinted arg AddrHint) ] + (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn where @@ -148,15 +141,15 @@ emitPrimOp [res] SparkOp [arg] live = do res' <- newTemp bWord emitForeignCall' PlayRisky [CmmHinted res' NoHint] - (CmmCallee newspark CCallConv) - [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) - , (CmmHinted arg AddrHint) ] - (Just vols) + (CmmCallee newspark CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) + , (CmmHinted arg AddrHint) ] + (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) where - newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) emitPrimOp [res] GetCCSOfOp [arg] _live = stmtC (CmmAssign (CmmLocal res) val) @@ -172,15 +165,15 @@ emitPrimOp [res] ReadMutVarOp [mutv] _ emitPrimOp [] WriteMutVarOp [mutv,var] live = do - stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var) - vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [{-no results-}] - (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - CCallConv) - [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) + stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var) + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) , (CmmHinted mutv AddrHint) ] - (Just vols) + (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn @@ -188,7 +181,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live -- r = ((StgArrWords *)(a))->bytes emitPrimOp [res] SizeofByteArrayOp [arg] _ = stmtC $ - CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord) + CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes @@ -208,13 +201,13 @@ emitPrimOp [res] ByteArrayContents_Char [arg] _ emitPrimOp [res] StableNameToIntOp [arg] _ = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)) --- #define eqStableNamezh(r,sn1,sn2) \ +-- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp [res] EqStableNameOp [arg1,arg2] _ = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 fixedHdrSize bWord, - cmmLoadIndexW arg2 fixedHdrSize bWord - ])) + cmmLoadIndexW arg1 fixedHdrSize bWord, + cmmLoadIndexW arg2 fixedHdrSize bWord + ])) emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ @@ -232,13 +225,13 @@ emitPrimOp [res] DataToTagOp [arg] _ {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable objects, even if they are in old space. When they become immutable, - they can be removed from this scavenge list. -} + they can be removed from this scavenge list. -} -- #define unsafeFreezzeArrayzh(r,a) --- { +-- { -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); --- r = a; --- } +-- r = a; +-- } emitPrimOp [res] UnsafeFreezeArrayOp [arg] _ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), CmmAssign (CmmLocal res) arg ] @@ -246,7 +239,7 @@ emitPrimOp [res] UnsafeFreezeArrayArrayOp [arg] _ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), CmmAssign (CmmLocal res) arg ] --- #define unsafeFreezzeByteArrayzh(r,a) r=(a) +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _ = stmtC (CmmAssign (CmmLocal res) arg) @@ -286,7 +279,7 @@ emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArr emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v emitPrimOp [res] SizeofArrayOp [arg] _ - = stmtC $ + = stmtC $ CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) emitPrimOp [res] SizeofMutableArrayOp [arg] live = emitPrimOp [res] SizeofArrayOp [arg] live @@ -430,16 +423,16 @@ emitPrimOp [res] op [arg] _ | Just (mop,rep) <- narrowOp op = stmtC (CmmAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) + CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) emitPrimOp [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live - emitForeignCall' PlayRisky - [CmmHinted res NoHint] - (CmmPrim prim) - [CmmHinted a NoHint | a<-args] -- ToDo: hints? - (Just vols) + emitForeignCall' PlayRisky + [CmmHinted res NoHint] + (CmmPrim prim) + [CmmHinted a NoHint | a<-args] -- ToDo: hints? + (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn @@ -458,9 +451,9 @@ nopOp Int2WordOp = True nopOp Word2IntOp = True nopOp Int2AddrOp = True nopOp Addr2IntOp = True -nopOp ChrOp = True -- Int# and Char# are rep'd the same -nopOp OrdOp = True -nopOp _ = False +nopOp ChrOp = True -- Int# and Char# are rep'd the same +nopOp OrdOp = True +nopOp _ = False -- These PrimOps turn into double casts @@ -471,7 +464,7 @@ narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) -narrowOp _ = Nothing +narrowOp _ = Nothing -- Native word signless ops @@ -494,10 +487,10 @@ translateOp AndOp = Just mo_wordAnd translateOp OrOp = Just mo_wordOr translateOp XorOp = Just mo_wordXor translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr +translateOp SllOp = Just mo_wordShl +translateOp SrlOp = Just mo_wordUShr -translateOp AddrRemOp = Just mo_wordURem +translateOp AddrRemOp = Just mo_wordURem -- Native word signed ops @@ -513,9 +506,9 @@ translateOp IntLeOp = Just mo_wordSLe translateOp IntGtOp = Just mo_wordSGt translateOp IntLtOp = Just mo_wordSLt -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp ISllOp = Just mo_wordShl +translateOp ISraOp = Just mo_wordSShr +translateOp ISrlOp = Just mo_wordUShr -- Native word unsigned ops @@ -633,9 +626,9 @@ callishOp _ = Nothing -- Helpers for translating various minor variants of array indexing. -- Bytearrays outside the heap; hence non-pointers -doIndexOffAddrOp, doIndexByteArrayOp - :: Maybe MachOp -> CmmType - -> [LocalReg] -> [CmmExpr] -> Code +doIndexOffAddrOp, doIndexByteArrayOp + :: Maybe MachOp -> CmmType + -> [LocalReg] -> [CmmExpr] -> Code doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx doIndexOffAddrOp _ _ _ _ @@ -643,7 +636,7 @@ doIndexOffAddrOp _ _ _ _ doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx -doIndexByteArrayOp _ _ _ _ +doIndexByteArrayOp _ _ _ _ = panic "CgPrimOp: doIndexByteArrayOp" doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code @@ -651,9 +644,9 @@ doReadPtrArrayOp res addr idx = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx -doWriteOffAddrOp, doWriteByteArrayOp - :: Maybe MachOp -> CmmType - -> [LocalReg] -> [CmmExpr] -> Code +doWriteOffAddrOp, doWriteByteArrayOp + :: Maybe MachOp -> CmmType + -> [LocalReg] -> [CmmExpr] -> Code doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val] = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val doWriteOffAddrOp _ _ _ _ @@ -661,7 +654,7 @@ doWriteOffAddrOp _ _ _ _ doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val] = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val -doWriteByteArrayOp _ _ _ _ +doWriteByteArrayOp _ _ _ _ = panic "CgPrimOp: doWriteByteArrayOp" doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code @@ -682,16 +675,16 @@ loadArrPtrsSize :: CmmExpr -> CmmExpr loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs -mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType - -> LocalReg -> CmmExpr -> CmmExpr -> Code +mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType + -> LocalReg -> CmmExpr -> CmmExpr -> Code mkBasicIndexedRead off Nothing read_rep res base idx = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)) mkBasicIndexedRead off (Just cast) read_rep res base idx = stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr off read_rep base idx])) + cmmLoadIndexOffExpr off read_rep base idx])) -mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType - -> CmmExpr -> CmmExpr -> CmmExpr -> Code +mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType + -> CmmExpr -> CmmExpr -> CmmExpr -> Code mkBasicIndexedWrite off Nothing write_rep base idx val = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) val) mkBasicIndexedWrite off (Just cast) write_rep base idx val diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index fb8f854c0b..499529d841 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -45,6 +45,7 @@ import Outputable import StaticFlags import Control.Monad +import Data.Maybe ----------------------------------------------------------------------------- -- Tail Calls @@ -103,17 +104,19 @@ performTailCall fun_info arg_amodes pending_assts -- to make the heap check easier. The tail-call sequence -- is very similar to returning an unboxed tuple, so we -- share some code. - do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes + do { (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes ; emitSimultaneously (pending_assts `plusStmts` arg_assts) ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info)) - ; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) } + ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) } | otherwise = do { fun_amode <- idInfoToAmode fun_info ; let assignSt = CmmAssign nodeReg fun_amode node_asst = oneStmt assignSt - opt_node_asst | nodeMustPointToIt lf_info = node_asst - | otherwise = noStmts + node_live = Just [node] + (opt_node_asst, opt_node_live) + | nodeMustPointToIt lf_info = (node_asst, node_live) + | otherwise = (noStmts, Just []) ; EndOfBlockInfo sp _ <- getEndOfBlockInfo ; dflags <- getDynFlags @@ -122,8 +125,8 @@ performTailCall fun_info arg_amodes pending_assts -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) - enterClosure = stmtC (CmmJump target []) + ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) + enterClosure = stmtC (CmmJump target node_live) -- If this is a scrutinee -- let's check if the closure is a constructor -- so we can directly jump to the alternatives switch @@ -137,18 +140,18 @@ performTailCall fun_info arg_amodes pending_assts -- As with any return, Node must point to it. ReturnIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False emitReturnInstr } + ; doFinalJump sp False $ emitReturnInstr node_live } -- A real constructor. Don't bother entering it, -- just do the right sort of return instead. -- As with any return, Node must point to it. ReturnCon _ -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False emitReturnInstr } + ; doFinalJump sp False $ emitReturnInstr node_live } JumpToIt lbl -> do { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) - ; doFinalJump sp False (jumpToLbl lbl) } + ; doFinalJump sp False $ jumpToLbl lbl opt_node_live } -- A slow function call via the RTS apply routines -- Node must definitely point to the thing @@ -163,7 +166,7 @@ performTailCall fun_info arg_amodes pending_assts ; let (apply_lbl, args, extra_args) = constructSlowCall arg_amodes - ; directCall sp apply_lbl args extra_args + ; directCall sp apply_lbl args extra_args node_live (node_asst `plusStmts` pending_assts) } @@ -179,7 +182,7 @@ performTailCall fun_info arg_amodes pending_assts -- The args beyond the arity go straight on the stack (arity_args, extra_args) = splitAt arity arg_amodes - ; directCall sp lbl arity_args extra_args + ; directCall sp lbl arity_args extra_args opt_node_live (opt_node_asst `plusStmts` pending_assts) } } @@ -203,7 +206,8 @@ performTailCall fun_info arg_amodes pending_assts -- No, enter the closure. ; enterClosure ; labelC is_constr - ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)) []) + ; stmtC (CmmJump (entryCode $ + CmmLit (CmmLabel lbl)) (Just [node])) } {- -- This is a scrutinee for a case expression @@ -218,7 +222,7 @@ performTailCall fun_info arg_amodes pending_assts ; stmtC (CmmCondBranch (cond1 tag) no_cons) ; stmtC (CmmCondBranch (cond2 tag) no_cons) -- Yes, jump to switch statement - ; stmtC (CmmJump (CmmLit (CmmLabel lbl)) []) + ; stmtC (CmmJump (CmmLit (CmmLabel lbl))) ; labelC no_cons -- No, enter the closure. ; enterClosure @@ -243,9 +247,9 @@ performTailCall fun_info arg_amodes pending_assts -} directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)] - -> [(CgRep, CmmExpr)] -> CmmStmts + -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts -> Code -directCall sp lbl args extra_args assts = do +directCall sp lbl args extra_args live_node assts = do let -- First chunk of args go in registers (reg_arg_amodes, stk_args) = assignCallRegs args @@ -255,14 +259,12 @@ directCall sp lbl args extra_args assts = do slow_stk_args = slowArgs extra_args reg_assts = assignToRegs reg_arg_amodes + live_args = map snd reg_arg_amodes + live_regs = Just $ (fromMaybe [] live_node) ++ live_args -- (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args) - - emitSimultaneously (reg_assts `plusStmts` - stk_assts `plusStmts` - assts) - - doFinalJump final_sp False (jumpToLbl lbl) + emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts + doFinalJump final_sp False $ jumpToLbl lbl live_regs -- ----------------------------------------------------------------------------- -- The final clean-up before we do a jump at the end of a basic block. @@ -296,20 +298,27 @@ performReturn :: Code -- The code to execute to actually do the return performReturn finish_code = do { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo - ; doFinalJump args_sp False{-not a LNE-} finish_code } + ; doFinalJump args_sp False finish_code } -- ---------------------------------------------------------------------------- -- Primitive Returns -- Just load the return value into the right register, and return. -performPrimReturn :: CgRep -> CmmExpr -- The thing to return - -> Code -performPrimReturn rep amode - = do { whenC (not (isVoidArg rep)) - (stmtC (CmmAssign ret_reg amode)) - ; performReturn emitReturnInstr } +performPrimReturn :: CgRep -> CmmExpr -> Code + +-- non-void return value +performPrimReturn rep amode | not (isVoidArg rep) + = do { stmtC (CmmAssign ret_reg amode) + ; performReturn $ emitReturnInstr live_regs } where - ret_reg = dataReturnConvPrim rep + -- careful here as 'dataReturnConvPrim' will panic if given a Void rep + ret_reg@(CmmGlobal r) = dataReturnConvPrim rep + live_regs = Just [r] + +-- void return value +performPrimReturn _ _ + = performReturn $ emitReturnInstr (Just []) + -- --------------------------------------------------------------------------- -- Unboxed tuple returns @@ -329,19 +338,21 @@ returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code returnUnboxedTuple amodes = do { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo ; tickyUnboxedTupleReturn (length amodes) - ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes + ; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes ; emitSimultaneously assts - ; doFinalJump final_sp False{-not a LNE-} emitReturnInstr } + ; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) } pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing -> [(CgRep, CmmExpr)] -- amodes of the components -> FCode (VirtualSpOffset, -- final Sp - CmmStmts) -- assignments (regs+stack) + CmmStmts, -- assignments (regs+stack) + [GlobalReg]) -- registers used (liveness) pushUnboxedTuple sp [] - = return (sp, noStmts) + = return (sp, noStmts, []) pushUnboxedTuple sp amodes = do { let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes + live_regs = map snd reg_arg_amodes -- separate the rest of the args into pointers and non-pointers (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes @@ -352,8 +363,8 @@ pushUnboxedTuple sp amodes ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args ; returnFC (final_sp, - reg_arg_assts `plusStmts` - ptr_assts `plusStmts` nptr_assts) } + reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts, + live_regs) } -- ----------------------------------------------------------------------------- @@ -403,13 +414,14 @@ tailCallPrim lbl args -- Hence the ASSERT( null leftovers ) arg_amodes <- getArgAmodes args ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes - jump_to_primop = jumpToLbl lbl + live_regs = Just $ map snd arg_regs + jump_to_primop = jumpToLbl lbl live_regs ; ASSERT(null leftovers) -- no stack-resident args emitSimultaneously (assignToRegs arg_regs) ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo - ; doFinalJump args_sp False{-not a LNE-} jump_to_primop } + ; doFinalJump args_sp False jump_to_primop } -- ----------------------------------------------------------------------------- -- Return Addresses @@ -438,9 +450,9 @@ pushReturnAddress _ = nopC -- ----------------------------------------------------------------------------- -- Misc. -jumpToLbl :: CLabel -> Code -- Passes no argument to the destination procedure -jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [{- No args -}]) +jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code +jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts assignToRegs reg_args diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 5274a176a0..2bd35c8796 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1020,7 +1020,7 @@ fixStgRegStmt stmt CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids - CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs + CmmJump addr live -> CmmJump (fixStgRegExpr addr) live -- CmmNop, CmmComment, CmmBranch, CmmReturn _other -> stmt diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index ac047edb89..34746984c2 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -43,7 +43,7 @@ module ClosureInfo ( closureFunInfo, isKnownFun, funTag, funTagLFInfo, tagForArity, clHasCafRefs, - enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, + enterIdLabel, enterReturnPtLabel, nodeMustPointToIt, CallMethod(..), getCallMethod, @@ -963,7 +963,10 @@ infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI = fst . labelsFromCI entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI = snd . labelsFromCI +entryLabelFromCI ci + | tablesNextToCode = info_lbl + | otherwise = entry_lbl + where (info_lbl, entry_lbl) = labelsFromCI ci labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) labelsFromCI cl@(ClosureInfo { closureName = name, @@ -1032,11 +1035,6 @@ enterIdLabel id | tablesNextToCode = mkInfoTableLabel id | otherwise = mkEntryLabel id -enterLocalIdLabel :: Name -> CafInfo -> CLabel -enterLocalIdLabel id - | tablesNextToCode = mkLocalInfoTableLabel id - | otherwise = mkLocalEntryLabel id - enterReturnPtLabel :: Unique -> CLabel enterReturnPtLabel name | tablesNextToCode = mkReturnInfoLabel name diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 3580481043..16edc9c4fb 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -247,7 +247,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff tso_stackobj = closureField oFFSET_StgTSO_stackobj -tso_CCCS = closureField oFFSET_StgTSO_CCCS +tso_CCCS = closureField oFFSET_StgTSO_cccs stack_STACK = closureField oFFSET_StgStack_stack stack_SP = closureField oFFSET_StgStack_sp diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index c64df7ecc5..ccf0777906 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -389,8 +389,8 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) -getDynFlags :: FCode DynFlags -getDynFlags = liftM cgd_dflags getInfoDown +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 5927faa78e..1824ae9136 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -333,16 +333,36 @@ emitPrimOp [res] FreezeArrayOp [src,src_off,n] = emitPrimOp [res] ThawArrayOp [src,src_off,n] = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n +emitPrimOp [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] = + doCopyArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableArrayOp src src_off dst dst_off n + -- Reading/writing pointer arrays -emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix -emitPrimOp [r] IndexArrayOp [obj,ix] = doReadPtrArrayOp r obj ix +emitPrimOp [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v + emitPrimOp [res] SizeofArrayOp [arg] = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) emitPrimOp [res] SizeofMutableArrayOp [arg] = emitPrimOp [res] SizeofArrayOp [arg] +emitPrimOp [res] SizeofArrayArrayOp [arg] + = emitPrimOp [res] SizeofArrayOp [arg] +emitPrimOp [res] SizeofMutableArrayArrayOp [arg] + = emitPrimOp [res] SizeofArrayOp [arg] -- IndexXXXoffAddr diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index fa22e7efea..d40ef52e18 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -105,7 +105,7 @@ find an occurence of an Id, we fetch it from the in-scope set. \begin{code} -lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message) +lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc) -- Returns (warnings, errors) lintCoreBindings binds = initL $ @@ -150,7 +150,7 @@ We use this to check all unfoldings that come in from interfaces lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe Message -- Nothing => OK + -> Maybe MsgDoc -- Nothing => OK lintUnfolding locn vars expr | isEmptyBag errs = Nothing @@ -664,31 +664,33 @@ lintInTy ty ; lintKind k ; return ty' } -lintInCo :: InCoercion -> LintM OutCoercion --- Check the coercion, and apply the substitution to it --- See Note [Linting type lets] -lintInCo co - = addLoc (InCo co) $ - do { co' <- applySubstCo co - ; _ <- lintCoercion co' - ; return co' } - ------------------- lintKind :: OutKind -> LintM () -- Check well-formedness of kinds: *, *->*, Either * (* -> *), etc +lintKind (TyVarTy kv) + = do { checkTyCoVarInScope kv + ; unless (isSuperKind (varType kv)) + (addErrL (hang (ptext (sLit "Badly kinded kind variable")) + 2 (ppr kv <+> dcolon <+> ppr (varType kv)))) } + lintKind (FunTy k1 k2) - = lintKind k1 >> lintKind k2 + = do { lintKind k1; lintKind k2 } lintKind kind@(TyConApp tc kis) - = do { unless (isSuperKindTyCon tc || tyConArity tc == length kis) - (addErrL malformed_kind) - ; mapM_ lintKind kis } - where - malformed_kind = hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind)) + | not (isSuperKind (tyConKind tc)) + = addErrL (hang (ptext (sLit "Type constructor") <+> quotes (ppr tc)) + 2 (ptext (sLit "cannot be used in a kind"))) + + | not (tyConArity tc == length kis) + = addErrL (hang (ptext (sLit "Unsaturated ype constructor in kind")) + 2 (quotes (ppr kind))) + + | otherwise + = mapM_ lintKind kis -lintKind (TyVarTy kv) = checkTyCoVarInScope kv lintKind kind - = addErrL (hang (ptext (sLit "Malformed kind:")) 2 (quotes (ppr kind))) + = addErrL (hang (ptext (sLit "Malformed kind:")) + 2 (quotes (ppr kind))) ------------------- lintTyBndrKind :: OutTyVar -> LintM () @@ -699,16 +701,118 @@ lintTyBndrKind tv = then return () -- kind forall else lintKind ki -- type forall +---------- +checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType +checkTcApp co n ty + | Just tys <- tyConAppArgs_maybe ty + , n < length tys + = return (tys !! n) + | otherwise + = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) + 2 (ptext (sLit "Offending type:") <+> ppr ty)) + ------------------- +lintType :: OutType -> LintM Kind +-- The returned Kind has itself been linted +lintType (TyVarTy tv) + = do { checkTyCoVarInScope tv + ; let kind = tyVarKind tv + ; lintKind kind + ; WARN( isSuperKind kind, msg ) + return kind } + where msg = hang (ptext (sLit "Expecting a type, but got a kind")) + 2 (ptext (sLit "Offending kind:") <+> ppr tv) + +lintType ty@(AppTy t1 t2) + = do { k1 <- lintType t1 + ; lint_ty_app ty k1 [t2] } + +lintType ty@(FunTy t1 t2) + = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] + +lintType ty@(TyConApp tc tys) + | tyConHasKind tc -- Guards for SuperKindOon + , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc + -- Check that primitive types are saturated + -- See Note [The kind invariant] in TypeRep + = lint_ty_app ty (tyConKind tc) tys + | otherwise + = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) + +lintType (ForAllTy tv ty) + = do { lintTyBndrKind tv + ; addInScopeVar tv (lintType ty) } + +---------------- +lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind +lint_ty_app ty k tys + = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + +---------------- +lint_co_app :: Coercion -> Kind -> [OutType] -> LintM () +lint_co_app ty k tys + = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys + ; return () } + +---------------- +lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind +-- (lint_kind_app d fun_kind arg_tys) +-- We have an application (f arg_ty1 .. arg_tyn), +-- where f :: fun_kind +-- Takes care of linting the OutTypes +lint_kind_app doc kfn tys = go kfn tys + where + fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc + , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) + , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] + + go kfn [] = return kfn + go kfn (ty:tys) = + case splitKindFunTy_maybe kfn of + { Nothing -> + case splitForAllTy_maybe kfn of + { Nothing -> failWithL fail_msg + ; Just (kv, body) -> do + -- Something of kind (forall kv. body) gets instantiated + -- with ty. 'kv' is a kind variable and 'ty' is a kind. + { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) + ; lintKind ty + ; go (substKiWith [kv] [ty] body) tys } } + ; Just (kfa, kfb) -> do + -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is + -- a type accepting kind 'kfa'. + { k <- lintType ty + ; lintKind kfa + ; unless (k `isSubKind` kfa) (addErrL fail_msg) + ; go kfb tys } } + +\end{code} + +%************************************************************************ +%* * + Linting coercions +%* * +%************************************************************************ + +\begin{code} +lintInCo :: InCoercion -> LintM OutCoercion +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; _ <- lintCoercion co' + ; return co' } + lintKindCoercion :: OutCoercion -> LintM OutKind -- Kind coercions are only reflexivity because they mean kind -- instantiation. See Note [Kind coercions] in Coercion +lintKindCoercion (Refl k) + = do { lintKind k + ; return k } lintKindCoercion co - = do { (k1,k2) <- lintCoercion co - ; checkL (k1 `eqKind` k2) - (hang (ptext (sLit "Non-refl kind coercion")) - 2 (ppr co)) - ; return k1 } + = failWithL (hang (ptext (sLit "Non-refl kind coercion")) + 2 (ppr co)) lintCoercion :: OutCoercion -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind @@ -732,14 +836,14 @@ lintCoercion co@(TyConAppCo tc cos) -- kis are the kind instantiations of tc ; kis <- mapM lintKindCoercion cokis ; (ss,ts) <- mapAndUnzipM lintCoercion cotys - ; check_co_app co ki (kis ++ ss) + ; lint_co_app co ki (kis ++ ss) ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } lintCoercion co@(AppCo co1 co2) = do { (s1,t1) <- lintCoercion co1 ; (s2,t2) <- lintCoercion co2 - ; check_co_app co (typeKind s1) [s2] + ; lint_co_app co (typeKind s1) [s2] ; return (mkAppTy s1 s2, mkAppTy t1 t2) } lintCoercion (ForAllCo v co) @@ -808,85 +912,6 @@ lintCoercion (InstCo co arg_ty) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } - ----------- -checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType -checkTcApp co n ty - | Just tys <- tyConAppArgs_maybe ty - , n < length tys - = return (tys !! n) - | otherwise - = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) - 2 (ptext (sLit "Offending type:") <+> ppr ty)) - -------------------- -lintType :: OutType -> LintM Kind -lintType (TyVarTy tv) - = do { checkTyCoVarInScope tv - ; let kind = tyVarKind tv - ; lintKind kind - ; WARN( isSuperKind kind, msg ) - return kind } - where msg = hang (ptext (sLit "Expecting a type, but got a kind")) - 2 (ptext (sLit "Offending kind:") <+> ppr tv) - -lintType ty@(AppTy t1 t2) - = do { k1 <- lintType t1 - ; lint_ty_app ty k1 [t2] } - -lintType ty@(FunTy t1 t2) - = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] - -lintType ty@(TyConApp tc tys) - | tyConHasKind tc -- Guards for SuperKindOon - , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc - -- Check that primitive types are saturated - -- See Note [The kind invariant] in TypeRep - = lint_ty_app ty (tyConKind tc) tys - | otherwise - = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) - -lintType (ForAllTy tv ty) - = do { lintTyBndrKind tv - ; addInScopeVar tv (lintType ty) } - ----------------- -lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind -lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys - ----------------- -check_co_app :: Coercion -> Kind -> [OutType] -> LintM () -check_co_app ty k tys = lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys >> return () - ----------------- -lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind --- Takes care of linting the OutTypes -lint_kind_app doc kfn tys = go kfn tys - where - fail_msg = vcat [ hang (ptext (sLit "Kind application error in")) 2 doc - , nest 2 (ptext (sLit "Function kind =") <+> ppr kfn) - , nest 2 (ptext (sLit "Arg types =") <+> ppr tys) ] - - go kfn [] = return kfn - go kfn (ty:tys) = - case splitKindFunTy_maybe kfn of - { Nothing -> - case splitForAllTy_maybe kfn of - { Nothing -> failWithL fail_msg - ; Just (kv, body) -> do - -- Something of kind (forall kv. body) gets instantiated - -- with ty. 'kv' is a kind variable and 'ty' is a kind. - { unless (isSuperKind (tyVarKind kv)) (addErrL fail_msg) - ; lintKind ty - ; go (substKiWith [kv] [ty] body) tys } } - ; Just (kfa, kfb) -> do - -- Something of kind (kfa -> kfb) is applied to ty. 'ty' is - -- a type accepting kind 'kfa'. - { k <- lintType ty - ; lintKind kfa - ; unless (k `isSubKind` kfa) (addErrL fail_msg) - ; go kfb tys } } - \end{code} %************************************************************************ @@ -905,7 +930,7 @@ newtype LintM a = WarnsAndErrs -> -- Error and warning messages so far (Maybe a, WarnsAndErrs) } -- Result and messages (if any) -type WarnsAndErrs = (Bag Message, Bag Message) +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) {- Note [Type substitution] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -953,23 +978,23 @@ initL m \end{code} \begin{code} -checkL :: Bool -> Message -> LintM () +checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg -failWithL :: Message -> LintM a +failWithL :: MsgDoc -> LintM a failWithL msg = LintM $ \ loc subst (warns,errs) -> (Nothing, (warns, addMsg subst errs msg loc)) -addErrL :: Message -> LintM () +addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \ loc subst (warns,errs) -> (Just (), (warns, addMsg subst errs msg loc)) -addWarnL :: Message -> LintM () +addWarnL :: MsgDoc -> LintM () addWarnL msg = LintM $ \ loc subst (warns,errs) -> (Just (), (addMsg subst warns msg loc, errs)) -addMsg :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message +addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addMsg subst msgs msg locs = ASSERT( notNull locs ) msgs `snocBag` mk_msg msg @@ -980,7 +1005,7 @@ addMsg subst msgs msg locs ptext (sLit "Substitution:") <+> ppr subst | otherwise = cxt1 - mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) + mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m = @@ -1052,7 +1077,7 @@ checkInScope loc_msg var = ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) (hsep [ppr var, loc_msg]) } -checkTys :: OutType -> OutType -> Message -> LintM () +checkTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied @@ -1110,39 +1135,39 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkNullAltsMsg :: CoreExpr -> Message +mkNullAltsMsg :: CoreExpr -> MsgDoc mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [Var] -> Message +mkDefaultArgsMsg :: [Var] -> MsgDoc mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc mkCaseAltMsg e ty1 ty2 = hang (text "Type of case alternatives not the same as the annotation on case:") 4 (vcat [ppr ty1, ppr ty2, ppr e]) -mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message +mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, hsep [ptext (sLit "Current TV subst"), ppr subst]] -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> Message +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> Message +mkBadConMsg :: TyCon -> DataCon -> MsgDoc mkBadConMsg tycon datacon = vcat [ text "In a case alternative, data constructor isn't in scrutinee type:", @@ -1150,7 +1175,7 @@ mkBadConMsg tycon datacon text "Data con:" <+> ppr datacon ] -mkBadPatMsg :: Type -> Type -> Message +mkBadPatMsg :: Type -> Type -> MsgDoc mkBadPatMsg con_result_ty scrut_ty = vcat [ text "In a case alternative, pattern result type doesn't match scrutinee type:", @@ -1158,17 +1183,17 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] -integerScrutinisedMsg :: Message +integerScrutinisedMsg :: MsgDoc integerScrutinisedMsg = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> Message +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc mkBadAltMsg scrut_ty alt = vcat [ text "Data alternative when scrutinee is not a tycon application", text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] -mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc mkNewTyDataConAltMsg scrut_ty alt = vcat [ text "Data alternative for newtype datacon", text "Scrutinee type:" <+> ppr scrut_ty, @@ -1178,21 +1203,21 @@ mkNewTyDataConAltMsg scrut_ty alt ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> Message +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkAppMsg fun_ty arg_ty arg = vcat [ptext (sLit "Argument value doesn't match argument type:"), hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkNonFunAppMsg fun_ty arg_ty arg = vcat [ptext (sLit "Non-function type in function position"), hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkLetErr :: TyVar -> CoreExpr -> Message +mkLetErr :: TyVar -> CoreExpr -> MsgDoc mkLetErr bndr rhs = vcat [ptext (sLit "Bad `let' binding:"), hang (ptext (sLit "Variable:")) @@ -1200,7 +1225,7 @@ mkLetErr bndr rhs hang (ptext (sLit "Rhs:")) 4 (ppr rhs)] -mkTyCoAppErrMsg :: TyVar -> Coercion -> Message +mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc mkTyCoAppErrMsg tyvar arg_co = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), hang (ptext (sLit "Type variable:")) @@ -1208,7 +1233,7 @@ mkTyCoAppErrMsg tyvar arg_co hang (ptext (sLit "Arg coercion:")) 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] -mkTyAppMsg :: Type -> Type -> Message +mkTyAppMsg :: Type -> Type -> MsgDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (ptext (sLit "Exp type:")) @@ -1216,7 +1241,7 @@ mkTyAppMsg ty arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkRhsMsg :: Id -> Type -> Message +mkRhsMsg :: Id -> Type -> MsgDoc mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), @@ -1224,14 +1249,14 @@ mkRhsMsg binder ty hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Rhs type:"), ppr ty]] -mkRhsPrimMsg :: Id -> CoreExpr -> Message +mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc mkRhsPrimMsg binder _rhs = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] ] -mkStrictMsg :: Id -> Message +mkStrictMsg :: Id -> MsgDoc mkStrictMsg binder = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), ppr binder], @@ -1239,7 +1264,7 @@ mkStrictMsg binder ] -mkKindErrMsg :: TyVar -> Type -> Message +mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty = vcat [ptext (sLit "Kinds don't match in type application:"), hang (ptext (sLit "Type variable:")) @@ -1247,7 +1272,7 @@ mkKindErrMsg tyvar arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkArityMsg :: Id -> Message +mkArityMsg :: Id -> MsgDoc mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has "), ppr (dmdTypeDepth dmd_ty), @@ -1260,24 +1285,24 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder -mkUnboxedTupleMsg :: Id -> Message +mkUnboxedTupleMsg :: Id -> MsgDoc mkUnboxedTupleMsg binder = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] -mkCastErr :: Type -> Type -> Message +mkCastErr :: Type -> Type -> MsgDoc mkCastErr from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), ptext (sLit "From-type:") <+> ppr from_ty, ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty ] -dupVars :: [[Var]] -> Message +dupVars :: [[Var]] -> MsgDoc dupVars vars = hang (ptext (sLit "Duplicate variables brought into scope")) 2 (ppr vars) -dupExtVars :: [[Name]] -> Message +dupExtVars :: [[Name]] -> MsgDoc dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) @@ -1310,7 +1335,7 @@ lintSplitCoVar cv Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) -mkCoVarLetErr :: CoVar -> Coercion -> Message +mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc mkCoVarLetErr covar co = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), hang (ptext (sLit "Coercion variable:")) @@ -1318,7 +1343,7 @@ mkCoVarLetErr covar co hang (ptext (sLit "Arg coercion:")) 4 (ppr co)] -mkCoAppErrMsg :: CoVar -> Coercion -> Message +mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc mkCoAppErrMsg covar arg_co = vcat [ptext (sLit "Kinds don't match in coercion application:"), hang (ptext (sLit "Coercion variable:")) @@ -1327,7 +1352,7 @@ mkCoAppErrMsg covar arg_co 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] -mkCoAppMsg :: Type -> Coercion -> Message +mkCoAppMsg :: Type -> Coercion -> MsgDoc mkCoAppMsg ty arg_co = vcat [text "Illegal type application:", hang (ptext (sLit "exp type:")) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index a8985d0019..ed288096f7 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -26,7 +26,7 @@ import CoreFVs import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import CoreSubst -import MkCore +import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here import Type import Literal import Coercion diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 04bb9d4a68..d7296e3e25 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -26,6 +26,7 @@ module CoreSyn ( mkIntLit, mkIntLitInt, mkWordLit, mkWordLitWord, + mkWord64LitWord64, mkInt64LitInt64, mkCharLit, mkStringLit, mkFloatLit, mkFloatLitFloat, mkDoubleLit, mkDoubleLitDouble, @@ -104,6 +105,7 @@ import Outputable import Util import Data.Data hiding (TyCon) +import Data.Int import Data.Word infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` @@ -341,6 +343,12 @@ Note [Type let] ~~~~~~~~~~~~~~~ See #type_let# +%************************************************************************ +%* * + Ticks +%* * +%************************************************************************ + \begin{code} -- | Allows attaching extra information to points in expressions data Tickish id = @@ -447,12 +455,12 @@ data CoreRule ru_act :: Activation, -- ^ When the rule is active -- Rough-matching stuff - -- see comments with InstEnv.Instance( is_cls, is_rough ) + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side -- Proper-matching stuff - -- see comments with InstEnv.Instance( is_tvs, is_tys ) + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) ru_bndrs :: [CoreBndr], -- ^ Variables quantified over ru_args :: [CoreExpr], -- ^ Left hand side arguments @@ -891,7 +899,7 @@ the occurrence info is wrong %************************************************************************ %* * -\subsection{The main data type} + AltCon %* * %************************************************************************ @@ -992,6 +1000,8 @@ instance Outputable b => Outputable (TaggedBndr b) where instance Outputable b => OutputableBndr (TaggedBndr b) where pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b \end{code} @@ -1042,6 +1052,12 @@ mkWordLitWord :: Word -> Expr b mkWordLit w = Lit (mkMachWord w) mkWordLitWord w = Lit (mkMachWord (toInteger w)) +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) + -- | Create a machine character literal expression of type @Char#@. -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' mkCharLit :: Char -> Expr b diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index d3a2ca5cbb..198ac7e610 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -21,7 +21,8 @@ module CoreUtils ( exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, + exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size @@ -181,6 +182,10 @@ mkCast :: CoreExpr -> Coercion -> CoreExpr mkCast e co | isReflCo co = e mkCast (Coercion e_co) co + | isCoVarType (pSnd (coercionKind co)) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce = Coercion new_co where -- g :: (s1 ~# s2) ~# (t1 ~# t2) @@ -752,35 +757,39 @@ it's applied only to dictionaries. -- -- We can only do this if the @y + 1@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception. -exprOkForSpeculation :: Expr b -> Bool +exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects -- Polymorphic in binder type -- There is one call at a non-Id binder type, in SetLevels -exprOkForSpeculation (Lit _) = True -exprOkForSpeculation (Type _) = True -exprOkForSpeculation (Coercion _) = True -exprOkForSpeculation (Var v) = appOkForSpeculation v [] -exprOkForSpeculation (Cast e _) = exprOkForSpeculation e + +expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool +expr_ok _ (Lit _) = True +expr_ok _ (Type _) = True +expr_ok _ (Coercion _) = True +expr_ok primop_ok (Var v) = app_ok primop_ok v [] +expr_ok primop_ok (Cast e _) = expr_ok primop_ok e -- Tick annotations that *tick* cannot be speculated, because these -- are meant to identify whether or not (and how often) the particular -- source expression was evaluated at runtime. -exprOkForSpeculation (Tick tickish e) +expr_ok primop_ok (Tick tickish e) | tickishCounts tickish = False - | otherwise = exprOkForSpeculation e + | otherwise = expr_ok primop_ok e -exprOkForSpeculation (Case e _ _ alts) - = exprOkForSpeculation e -- Note [exprOkForSpeculation: case expressions] - && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts - && altsAreExhaustive alts -- Note [exprOkForSpeculation: exhaustive alts] +expr_ok primop_ok (Case e _ _ alts) + = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions] + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts -- Note [Exhaustive alts] -exprOkForSpeculation other_expr +expr_ok primop_ok other_expr = case collectArgs other_expr of - (Var f, args) -> appOkForSpeculation f args + (Var f, args) -> app_ok primop_ok f args _ -> False ----------------------------- -appOkForSpeculation :: Id -> [Expr b] -> Bool -appOkForSpeculation fun args +app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool +app_ok primop_ok fun args = case idDetails fun of DFunId new_type -> not new_type -- DFuns terminate, unless the dict is implemented @@ -794,7 +803,7 @@ appOkForSpeculation fun args PrimOpId op | isDivOp op -- Special case for dividing operations that fail , [arg1, Lit lit] <- args -- only if the divisor is zero - -> not (isZeroLit lit) && exprOkForSpeculation arg1 + -> not (isZeroLit lit) && expr_ok primop_ok arg1 -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner looop @@ -802,14 +811,14 @@ appOkForSpeculation fun args -> True | otherwise - -> primOpOkForSpeculation op && - all exprOkForSpeculation args - -- A bit conservative: we don't really need + -> primop_ok op -- A bit conservative: we don't really need + && all (expr_ok primop_ok) args + -- to care about lazy arguments, but this is easy _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF || idArity fun > n_val_args -- Partial apps - || (n_val_args ==0 && + || (n_val_args == 0 && isEvaldUnfolding (idUnfolding fun)) -- Let-bound values where n_val_args = valArgCount args @@ -872,13 +881,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this: The inner case is redundant, and should be nuked. -Note [exprOkForSpeculation: exhaustive alts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Exhaustive alts] +~~~~~~~~~~~~~~~~~~~~~~ We might have something like case x of { A -> ... _ -> ...(case x of { B -> ...; C -> ... })... -Here, the inner case is fine, becuase the A alternative +Here, the inner case is fine, because the A alternative can't happen, but it's not ok to float the inner case outside the outer one (even if we know x is evaluated outside), because then it would be non-exhaustive. See Trac #5453. @@ -1284,10 +1293,10 @@ data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } instance Outputable CoreStats where - ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) = - text "size of" <+> vcat [ text "terms =" <+> int i1 - , text "types =" <+> int i2 - , text "coercions =" <+> int i3 ] + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) + = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, + ptext (sLit "types:") <+> intWithCommas i2 <> comma, + ptext (sLit "coercions:") <+> intWithCommas i3]) plusCS :: CoreStats -> CoreStats -> CoreStats plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index dd41184994..5d1c19bc5f 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -21,6 +21,9 @@ module MkCore ( mkFloatExpr, mkDoubleExpr, mkCharExpr, mkStringExpr, mkStringExprFS, + -- * Floats + FloatBind(..), wrapFloat, + -- * Constructing/deconstructing implicit parameter boxes mkIPUnbox, mkIPBox, @@ -288,7 +291,7 @@ mkIPUnbox ipx = Var x `Cast` mkAxInstCo (ipCoAxiom ip) [ty] \begin{code} mkEqBox :: Coercion -> CoreExpr -mkEqBox co = ASSERT( typeKind ty2 `eqKind` k ) +mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) Var (dataConWorkId eqBoxDataCon) `mkTyApps` [k, ty1, ty2] `App` Coercion co where Pair ty1 ty2 = coercionKind co k = typeKind ty1 @@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type mkBigCoreTupTy = mkChunkified mkBoxedTupleTy \end{code} + +%************************************************************************ +%* * + Floats +%* * +%************************************************************************ + +\begin{code} +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating cases] in SetLevels + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] +\end{code} + %************************************************************************ %* * \subsection{Tuple destructors} diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 9def8e8ca7..7487c66025 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -21,6 +21,7 @@ module PprCore ( import CoreSyn import Literal( pprLiteral ) +import Name( pprInfixName, pprPrefixName ) import Var import Id import IdInfo @@ -268,6 +269,8 @@ and @pprCoreExpr@ functions. \begin{code} instance OutputableBndr Var where pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 84cb6d628f..2d0ad237fc 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -41,7 +41,8 @@ import CLabel import Util import Data.Array -import System.Directory ( createDirectoryIfMissing ) +import Data.Time +import System.Directory import Trace.Hpc.Mix import Trace.Hpc.Util @@ -158,7 +159,7 @@ writeMixEntries dflags mod count entries filename tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges. createDirectoryIfMissing True hpc_mod_dir - modTime <- getModificationTime filename + modTime <- getModificationUTCTime filename let entries' = [ (hpcPos, box) | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] when (length entries' /= count) $ do @@ -1097,7 +1098,7 @@ type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) -- This hash only has to be hashed at Mix creation time, -- and is for sanity checking only. -mixHash :: FilePath -> Integer -> Int -> [MixEntry] -> Int +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) \end{code} diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 1748ce7cac..663c289d3c 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -21,7 +21,7 @@ import Match import DsUtils import DsMonad -import HsSyn hiding (collectPatBinders, collectPatsBinders ) +import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders ) import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes @@ -265,21 +265,21 @@ Translation of command judgements of the form A | xs |- c :: [ts] t \begin{code} -dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id +dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id] -> DsM (CoreExpr, IdSet) -dsLCmd ids local_vars env_ids stack res_ty cmd - = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) +dsLCmd ids local_vars stack res_ty cmd env_ids + = dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids dsCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command - -> [Id] -- list of vars in the input to this command - -- This is typically fed back, - -- so don't pull on it too early -> [Type] -- type of the stack -> Type -- return type of the command -> HsCmd Id -- command to desugar + -> [Id] -- list of vars in the input to this command + -- This is typically fed back, + -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -- A |- f :: a (t*ts) t' -- A, xs |- arg :: t @@ -288,8 +288,9 @@ dsCmd :: DsCmdEnv -- arrow combinators -- -- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f -dsCmd ids local_vars env_ids stack res_ty - (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)= do +dsCmd ids local_vars stack res_ty + (HsArrApp arrow arg arrow_ty HsFirstOrderApp _) + env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty @@ -304,7 +305,7 @@ dsCmd ids local_vars env_ids stack res_ty res_ty core_make_arg core_arrow, - exprFreeVars core_arg `intersectVarSet` local_vars) + exprFreeIds core_arg `intersectVarSet` local_vars) -- A, xs |- f :: a (t*ts) t' -- A, xs |- arg :: t @@ -313,8 +314,9 @@ dsCmd ids local_vars env_ids stack res_ty -- -- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app -dsCmd ids local_vars env_ids stack res_ty - (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = do +dsCmd ids local_vars stack res_ty + (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) + env_ids = do let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty @@ -332,7 +334,7 @@ dsCmd ids local_vars env_ids stack res_ty res_ty core_make_pair (do_app ids arg_ty res_ty), - (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg) + (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg) `intersectVarSet` local_vars) -- A | ys |- c :: [t:ts] t' @@ -342,7 +344,7 @@ dsCmd ids local_vars env_ids stack res_ty -- -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c -dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do +dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do core_arg <- dsLExpr arg let arg_ty = exprType core_arg @@ -363,8 +365,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do res_ty core_map core_cmd, - (exprFreeVars core_arg `intersectVarSet` local_vars) - `unionVarSet` free_vars) + free_vars `unionVarSet` + (exprFreeIds core_arg `intersectVarSet` local_vars)) -- A | ys |- c :: [ts] t' -- ----------------------------------------------- @@ -372,11 +374,12 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do -- -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c -dsCmd ids local_vars env_ids stack res_ty - (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = do +dsCmd ids local_vars stack res_ty + (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) + env_ids = do let pat_vars = mkVarSet (collectPatsBinders pats) - local_vars' = local_vars `unionVarSet` pat_vars + local_vars' = pat_vars `unionVarSet` local_vars stack' = drop (length pats) stack (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body stack_ids <- mapM newSysLocalDs stack @@ -399,8 +402,8 @@ dsCmd ids local_vars env_ids stack res_ty return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body, free_vars `minusVarSet` pat_vars) -dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) - = dsLCmd ids local_vars env_ids stack res_ty cmd +dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids + = dsLCmd ids local_vars stack res_ty cmd env_ids -- A, xs |- e :: Bool -- A | xs1 |- c1 :: [ts] t @@ -412,7 +415,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- c1 ||| c2 -dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do +dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd) + env_ids = do core_cond <- dsLExpr cond (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd @@ -428,7 +432,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = then_ty = envStackType then_ids stack else_ty = envStackType else_ids stack sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars + fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_ids) core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) @@ -472,7 +476,8 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do +dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) + env_ids = do stack_ids <- mapM newSysLocalDs stack -- Extract and desugar the leaf commands in the case, building tuple @@ -482,7 +487,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = do (core_leaf, _fvs, leaf_ids) <- - dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf + dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack res_ty leaf return ([mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) @@ -522,7 +527,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty')) core_matches <- matchEnvStack env_ids stack_ids core_body return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeVars core_body `intersectVarSet` local_vars) + exprFreeIds core_body `intersectVarSet` local_vars) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -530,10 +535,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ -- -- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c -dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do +dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders binds) - local_vars' = local_vars `unionVarSet` defined_vars + local_vars' = defined_vars `unionVarSet` local_vars (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body stack_ids <- mapM newSysLocalDs stack @@ -547,26 +552,25 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do res_ty core_map core_body, - exprFreeVars core_binds `intersectVarSet` local_vars) + exprFreeIds core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _) - = dsCmdDo ids local_vars env_ids res_ty stmts +dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids + = dsCmdDo ids local_vars res_ty stmts env_ids -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A | xs |- ci :: [tsi] ti -- ----------------------------------- -- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = do +dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, unionVarSets fv_sets) - -dsCmd ids local_vars env_ids stack res_ty (HsTick tickish expr) = do - (expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr +dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do + (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids return (Tick tickish expr1, id_set) dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) @@ -578,9 +582,9 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) dsTrimCmdArg :: IdSet -- set of local vars available to this command -> [Id] -- list of vars in the input to this command - -> LHsCmdTop Id -- command argument to desugar + -> LHsCmdTop Id -- command argument to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do meth_ids <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd @@ -603,11 +607,24 @@ dsfixCmd -> Type -- return type of the command -> LHsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression - IdSet, -- set of local vars that occur free - [Id]) -- set as a list, fed back + IdSet, -- subset of local vars that occur free + [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stack cmd_ty cmd - = fixDs (\ ~(_,_,env_ids') -> do - (core_cmd, free_vars) <- dsLCmd ids local_vars env_ids' stack cmd_ty cmd + = trimInput (dsLCmd ids local_vars stack cmd_ty cmd) + +-- Feed back the list of local variables actually used a command, +-- for use as the input tuple of the generated arrow. + +trimInput + :: ([Id] -> DsM (CoreExpr, IdSet)) + -> DsM (CoreExpr, -- desugared expression + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list, fed back to + -- the inner function to form the tuple of + -- inputs to the arrow. +trimInput build_arrow + = fixDs (\ ~(_,_,env_ids) -> do + (core_cmd, free_vars) <- build_arrow env_ids return (core_cmd, free_vars, varSetElems free_vars)) \end{code} @@ -620,31 +637,29 @@ Translation of command judgements of the form dsCmdDo :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement + -> Type -- return type of the statement + -> [LStmt Id] -- statements to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early - -> Type -- return type of the statement - -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -- A | xs |- c :: [] t -- -------------------------- -- A | xs |- do { c } :: [] t -dsCmdDo _ _ _ _ [] = panic "dsCmdDo" +dsCmdDo _ _ _ [] _ = panic "dsCmdDo" -dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)] - = dsLCmd ids local_vars env_ids [] res_ty body +dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids + = dsLCmd ids local_vars [] res_ty body env_ids -dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do +dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do let bound_vars = mkVarSet (collectLStmtBinders stmt) - local_vars' = local_vars `unionVarSet` bound_vars - (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do - (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts - return (core_stmts, fv_stmts, varSetElems fv_stmts)) - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt + local_vars' = bound_vars `unionVarSet` local_vars + (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts) + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids return (do_compose ids (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids') @@ -658,21 +673,21 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id +dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id] -> DsM (CoreExpr, IdSet) -dsCmdLStmt ids local_vars env_ids out_ids cmd - = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) +dsCmdLStmt ids local_vars out_ids cmd env_ids + = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids dsCmdStmt :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement + -> [Id] -- list of vars in the output of this statement + -> Stmt Id -- statement to desugar -> [Id] -- list of vars in the input to this statement -- This is typically fed back, -- so don't pull on it too early - -> [Id] -- list of vars in the output of this statement - -> Stmt Id -- statement to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -- A | xs1 |- c :: [] t -- A | xs' |- do { ss } :: [] t' @@ -682,7 +697,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do +dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd core_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -711,7 +726,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do +dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd let pat_ty = hsLPatType pat @@ -760,7 +775,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do -- -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = 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 @@ -769,7 +784,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy out_ids) core_map, - exprFreeVars core_binds `intersectVarSet` local_vars) + exprFreeIds core_binds `intersectVarSet` local_vars) -- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ... -- A | xs' |- do { ss' } :: [] t @@ -785,9 +800,11 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do -- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>> -- arr (\((xs1),(xs2)) -> (xs')) >>> ss' -dsCmdStmt ids local_vars env_ids out_ids - (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_rec_rets = rhss }) = do +dsCmdStmt ids local_vars out_ids + (RecStmt { recS_stmts = stmts + , recS_later_ids = later_ids, recS_rec_ids = rec_ids + , recS_later_rets = later_rets, recS_rec_rets = rec_rets }) + env_ids = do let env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set @@ -807,7 +824,7 @@ dsCmdStmt ids local_vars env_ids out_ids --- loop (...) (core_loop, env1_id_set, env1_ids) - <- dsRecCmd ids local_vars stmts later_ids rec_ids rhss + <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) @@ -838,25 +855,41 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) -- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>> -- ss >>> --- arr (\ (out_ids) -> ((later_ids),(rhss))) >>> - -dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id] - -> DsM (CoreExpr, VarSet, [Var]) -dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do +-- arr (\ (out_ids) -> ((later_rets),(rec_rets))) >>> + +dsRecCmd + :: DsCmdEnv -- arrow combinators + -> IdSet -- set of local vars available to this statement + -> [LStmt Id] -- list of statements inside the RecCmd + -> [Id] -- list of vars defined here and used later + -> [HsExpr Id] -- expressions corresponding to later_ids + -> [Id] -- list of vars fed back through the loop + -> [HsExpr Id] -- expressions corresponding to rec_ids + -> DsM (CoreExpr, -- desugared statement + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list + +dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do let + later_id_set = mkVarSet later_ids rec_id_set = mkVarSet rec_ids - out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set) - out_ty = mkBigCoreVarTupTy out_ids - local_vars' = local_vars `unionVarSet` rec_id_set + local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars - -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) + -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets)) - core_rhss <- mapM dsExpr rhss + core_later_rets <- mapM dsExpr later_rets + core_rec_rets <- mapM dsExpr rec_rets let - later_tuple = mkBigCoreVarTup later_ids + -- possibly polymorphic version of vars of later_ids and rec_ids + out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets))) + out_ty = mkBigCoreVarTupTy out_ids + + later_tuple = mkBigCoreTup core_later_rets later_ty = mkBigCoreVarTupTy later_ids - rec_tuple = mkBigCoreTup core_rhss + + rec_tuple = mkBigCoreTup core_rec_rets rec_ty = mkBigCoreVarTupTy rec_ids + out_pair = mkCorePairExpr later_tuple rec_tuple out_pair_ty = mkCorePairTy later_ty rec_ty @@ -905,34 +938,32 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression - IdSet, -- set of local vars that occur free - [Id]) -- input vars + IdSet, -- subset of local vars that occur free + [Id]) -- same local vars as a list dsfixCmdStmts ids local_vars out_ids stmts - = fixDs (\ ~(_,_,env_ids) -> do - (core_stmts, fv_stmts) <- dsCmdStmts ids local_vars env_ids out_ids stmts - return (core_stmts, fv_stmts, varSetElems fv_stmts)) + = trimInput (dsCmdStmts ids local_vars out_ids stmts) dsCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement - -> [Id] -- list of vars in the input to these statements -> [Id] -- output vars of these statements - -> [LStmt Id] -- statements to desugar + -> [LStmt Id] -- statements to desugar + -> [Id] -- list of vars in the input to these statements -> DsM (CoreExpr, -- desugared expression - IdSet) -- set of local vars that occur free + IdSet) -- subset of local vars that occur free -dsCmdStmts ids local_vars env_ids out_ids [stmt] - = dsCmdLStmt ids local_vars env_ids out_ids stmt +dsCmdStmts ids local_vars out_ids [stmt] env_ids + = dsCmdLStmt ids local_vars out_ids stmt env_ids -dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do +dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do let bound_vars = mkVarSet (collectLStmtBinders stmt) - local_vars' = local_vars `unionVarSet` bound_vars + local_vars' = bound_vars `unionVarSet` local_vars (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts - (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt + (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids return (do_compose ids (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy env_ids') @@ -941,7 +972,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do core_stmts, fv_stmt) -dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []" +dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []" \end{code} @@ -1081,4 +1112,21 @@ add_ev_bndr :: EvBind -> [Id] -> [Id] add_ev_bndr (EvBind b _) bs | isId b = b:bs | otherwise = bs -- A worry: what about coercion variable binders?? + +collectLStmtsBinders :: [LStmt Id] -> [Id] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectLStmtBinders :: LStmt Id -> [Id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt Id -> [Id] +collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt binds) = collectLocalBinders binds +collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders + $ concatMap fst xs +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids + \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index d44943c347..1380774c71 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -32,6 +32,7 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things +import Literal ( Literal(MachStr) ) import CoreSubst import MkCore import CoreUtils @@ -40,6 +41,7 @@ import CoreUnfold import CoreFVs import Digraph + import TyCon ( isTupleTyCon, tyConDataCons_maybe ) import TcEvidence import TcType @@ -49,7 +51,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon ) import Id import Class import DataCon ( dataConWorkId ) -import Name ( localiseName ) +import Name ( Name, localiseName ) import MkId ( seqId ) import Var import VarSet @@ -61,9 +63,11 @@ import Maybes import OrdList import Bag import BasicTypes hiding ( TopLevel ) +import DynFlags import FastString +import ErrUtils( MsgDoc ) import Util - +import Control.Monad( when ) import MonadUtils \end{code} @@ -395,6 +399,13 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) -- Moreover, classops don't (currently) have an inl_sat arity set -- (it would be Just 0) and that in turn makes makeCorePair bleat + | no_act_spec && isNeverActive rule_act + = putSrcSpanDs loc $ + do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:") + <+> quotes (ppr poly_id)) + ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that + -- See Note [Activation pragmas for SPECIALISE] + | otherwise = putSrcSpanDs loc $ do { let poly_name = idName poly_id @@ -410,28 +421,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; let spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - id_inl = idInlinePragma poly_id - - -- See Note [Activation pragmas for SPECIALISE] - inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl - | not is_local_id -- See Note [Specialising imported functions] - -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = id_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - spec_prag_act = inlinePragmaActivation spec_inl - - -- See Note [Activation pragmas for SPECIALISE] - -- no_act_spec is True if the user didn't write an explicit - -- phase specification in the SPECIALISE pragma - no_act_spec = case inlinePragmaSpec spec_inl of - NoInline -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act - rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit - | otherwise = spec_prag_act -- Specified by user - rule = mkRule False {- Not auto -} is_local_id (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) rule_act poly_name @@ -441,6 +430,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) spec_rhs = dsHsWrapper spec_co poly_rhs spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs + ; dflags <- getDynFlags + ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) + (warnDs (specOnInline poly_name)) ; return (Just (spec_pair `consOL` unf_pairs, rule)) } } } where @@ -455,6 +447,29 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) -- The type checker has checked that it *has* an unfolding + id_inl = idInlinePragma poly_id + + -- See Note [Activation pragmas for SPECIALISE] + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_prag_act = inlinePragmaActivation spec_inl + + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit + | otherwise = spec_prag_act -- Specified by user + + specUnfolding :: HsWrapper -> Type -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr)) {- [Dec 10: TEMPORARILY commented out, until we can straighten out how to @@ -467,6 +482,10 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops) -} specUnfolding _ _ _ = return (noUnfolding, nilOL) + +specOnInline :: Name -> MsgDoc +specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") + <+> quotes (ppr f) \end{code} @@ -683,7 +702,9 @@ dsEvTerm (EvId v) = Var v dsEvTerm (EvCast v co) = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is - -- unnecessary to call varToCoreExpr v here. + -- unnecessary to call varToCoreExpr v here. +dsEvTerm (EvKindCast v co) + = dsTcCoercion co $ (\_ -> Var v) dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox @@ -703,7 +724,10 @@ dsEvTerm (EvSuperClass d n) = Var sc_sel_id `mkTyApps` tys `App` Var d where sc_sel_id = classSCSelId cls n -- Zero-indexed - (cls, tys) = getClassPredTys (evVarPred d) + (cls, tys) = getClassPredTys (evVarPred d) +dsEvTerm (EvDelayedError ty msg) = Var errorId `mkTyApps` [ty] `mkApps` [litMsg] + where errorId = rUNTIME_ERROR_ID + litMsg = Lit (MachStr msg) --------------------------------------- dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index a47e617a7c..b34640a010 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -683,7 +683,7 @@ makes all list literals be generated via the simple route. dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs - = do { dflags <- getDOptsDs + = do { dflags <- getDynFlags ; xs' <- mapM dsLExpr xs ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' ; if opt_SimpleListLiterals -- -fsimple-list-literals @@ -758,21 +758,21 @@ dsDo stmts = ASSERT( length rec_ids > 0 ) goL (new_bind_stmt : stmts) where - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) + new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats) mfix_app bind_op noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids - tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case + tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] (mkFunTy tup_ty body_ty)) - mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty - ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) ret_stmt = noLoc $ mkLastStmt ret_app -- This LastStmt will be desugared with dsDo, -- which ignores the return_op in the LastStmt, diff --git a/compiler/deSugar/DsExpr.lhs-boot b/compiler/deSugar/DsExpr.lhs-boot index 2a6d09b48e..03a47ed41b 100644 --- a/compiler/deSugar/DsExpr.lhs-boot +++ b/compiler/deSugar/DsExpr.lhs-boot @@ -1,16 +1,9 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) -import Var ( Id ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) +import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) +import Var ( Id ) +import DsMonad ( DsM ) +import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr dsLExpr :: LHsExpr Id -> DsM CoreExpr diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 30d4af9804..b613fbdcec 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -138,7 +138,7 @@ dsCImport :: Id -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do let ty = pFst $ coercionKind co - fod = case tyConAppTyCon_maybe ty of + fod = case tyConAppTyCon_maybe (dropForAlls ty) of Just tycon | tyConUnique tycon == funPtrTyConKey -> IsFunction @@ -345,7 +345,7 @@ dsFExport fn_id co ext_name cconv isDyn = do -- The function returns t Nothing -> (orig_res_ty, False) - dflags <- getDOpts + dflags <- getDynFlags return $ mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 4ad8006b39..917e8b19ed 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -47,7 +47,7 @@ dsListComp :: [LStmt Id] -> Type -- Type of entire list -> DsM CoreExpr dsListComp lquals res_ty = do - dflags <- getDOptsDs + dflags <- getDynFlags let quals = map unLoc lquals elt_ty = case tcTyConAppArgs res_ty of [elt_ty] -> elt_ty diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 103f70f9e7..4105a9e56c 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -129,10 +129,12 @@ repTopDs group decls <- addBinds ss (do { val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; - inst_ds <- mapM repInstD' (hs_instds group) ; + inst_ds <- mapM repInstD (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds + ++ catMaybes inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -307,8 +309,12 @@ repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD -- represent instance declarations -- -repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now +repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repInstD (L loc (FamInstDecl fi_decl)) + = repTyClD (L loc fi_decl) + + +repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now = do { dec <- addTyVarBinds tvs $ \_ -> -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't @@ -327,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now ; ats1 <- repLAssocFamInst ats ; decls <- coreList decQTyConName (ats1 ++ binds1) ; repInst cxt1 inst_ty1 decls } - ; return (loc, dec) } + ; return (Just (loc, dec)) } where Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index bf05fdffe2..e68e6db7c2 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -20,7 +20,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, woptDs, + getGhcModeDs, doptDs, woptDs, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, PArrBuiltin(..), @@ -226,7 +226,7 @@ initDs hsc_env mod rdr_env type_env thing_inside where loadOneModule :: ModuleName -- the module to load -> DsM Bool -- under which condition - -> Message -- error message if module not found + -> MsgDoc -- error message if module not found -> DsM GlobalRdrEnv -- empty if condition 'False' loadOneModule modname check err = do { doLoad <- check @@ -267,7 +267,7 @@ initDsTc thing_inside = do { this_mod <- getModule ; tcg_env <- getGblEnv ; msg_var <- getErrsVar - ; dflags <- getDOpts + ; dflags <- getDynFlags ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env ds_envs = mkDsEnvs dflags this_mod rdr_env type_env msg_var @@ -346,9 +346,6 @@ We can also reach out and either set/grab location information from the @SrcSpan@ being carried around. \begin{code} -getDOptsDs :: DsM DynFlags -getDOptsDs = getDOpts - doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs = doptM @@ -356,7 +353,7 @@ woptDs :: WarningFlag -> TcRnIf gbl lcl Bool woptDs = woptM getGhcModeDs :: DsM GhcMode -getGhcModeDs = getDOptsDs >>= return . ghcMode +getGhcModeDs = getDynFlags >>= return . ghcMode getModuleDs :: DsM Module getModuleDs = do { env <- getGblEnv; return (ds_mod env) } @@ -370,8 +367,7 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) warnDs :: SDoc -> DsM () warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkWarnMsg loc (ds_unqual env) - (ptext (sLit "Warning:") <+> warn) + ; let msg = mkWarnMsg loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } failWithDs :: SDoc -> DsM a diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 626b6ee795..5473edf216 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -558,7 +558,7 @@ we are going to make EITHER EITHER (A) v = e (where v is fresh) x = case v of p -> x - y = case v of p -> x + y = case v of p -> y OR (B) t = case e of p -> (x,y) x = case t of (x,_) -> x diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index cd0153e3ac..974d3183a7 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -66,7 +66,7 @@ matchCheck :: DsMatchContext -> DsM MatchResult -- Desugared result! matchCheck ctx vars ty qs - = do { dflags <- getDOptsDs + = do { dflags <- getDynFlags ; matchCheck_really dflags ctx vars ty qs } matchCheck_really :: DynFlags diff --git a/compiler/deSugar/Match.lhs-boot b/compiler/deSugar/Match.lhs-boot index 31ee36b6e6..d10cda961e 100644 --- a/compiler/deSugar/Match.lhs-boot +++ b/compiler/deSugar/Match.lhs-boot @@ -1,42 +1,35 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Match where -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup ) -import Name ( Name ) +import Var ( Id ) +import TcType ( Type ) +import DsMonad ( DsM, EquationInfo, MatchResult ) +import CoreSyn ( CoreExpr ) +import HsSyn ( LPat, HsMatchContext, MatchGroup ) +import Name ( Name ) -match :: [Id] +match :: [Id] -> Type - -> [EquationInfo] - -> DsM MatchResult + -> [EquationInfo] + -> DsM MatchResult matchWrapper - :: HsMatchContext Name + :: HsMatchContext Name -> MatchGroup Id - -> DsM ([Id], CoreExpr) + -> DsM ([Id], CoreExpr) matchSimply - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr + :: CoreExpr + -> HsMatchContext Name + -> LPat Id + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr matchSinglePat - :: CoreExpr - -> HsMatchContext Name - -> LPat Id + :: CoreExpr + -> HsMatchContext Name + -> LPat Id -> Type - -> MatchResult - -> DsM MatchResult + -> MatchResult + -> DsM MatchResult \end{code} diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index bb50fffa12..2b00da303e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -61,15 +61,18 @@ Library if !flag(base3) && !flag(base4) Build-Depends: base < 3 + if flag(stage1) && impl(ghc < 7.5) + Build-Depends: old-time >= 1 && < 1.2 + if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, process >= 1 && < 1.2, bytestring >= 0.9 && < 0.10, - old-time >= 1 && < 1.1, + time < 1.5, containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4 + array >= 0.1 && < 0.5 - Build-Depends: filepath >= 1 && < 1.3 + Build-Depends: filepath >= 1 && < 1.4 Build-Depends: Cabal, hpc if os(windows) Build-Depends: Win32 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 5464b4714c..f5b93db162 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -150,6 +150,10 @@ $(eval $(call clean-target,compiler,config_hs,compiler/main/Config.hs)) PLATFORM_H = ghc_boot_platform.h +ifeq "$(BuildingCrossCompiler)" "YES" +compiler/stage1/$(PLATFORM_H) : compiler/stage2/$(PLATFORM_H) + cp $< $@ +else compiler/stage1/$(PLATFORM_H) : mk/config.mk mk/project.mk | $$(dir $$@)/. $(call removeFiles,$@) @echo "Creating $@..." @@ -192,6 +196,7 @@ endif @echo >> $@ @echo "#endif /* __PLATFORM_H__ */" >> $@ @echo "Done." +endif # For stage2 and above, the BUILD platform is the HOST of stage1, and # the HOST platform is the TARGET of stage1. The TARGET remains the same @@ -258,7 +263,7 @@ PRIMOP_BITS = compiler/primop-data-decl.hs-incl \ compiler/primop-strictness.hs-incl \ compiler/primop-primop-info.hs-incl -compiler_CPP_OPTS += -I$(GHC_INCLUDE_DIR) +compiler_CPP_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS)) compiler_CPP_OPTS += ${GhcCppOpts} $(PRIMOPS_TXT) compiler/parser/Parser.y: %: %.pp compiler/stage1/$(PLATFORM_H) @@ -489,13 +494,6 @@ $(eval $(call compiler-hs-dependency,PrimOp,$(PRIMOP_BITS))) compiler/prelude/PrimOp_HC_OPTS += -fforce-recomp compiler/main/Constants_HC_OPTS += -fforce-recomp -# Workaround for #4003 in GHC 6.12.2. It didn't happen in 6.12.1, and -# will be fixed in 6.12.3. Unfortunately we don't have a way to do -# this for just stage1 in the build system. -ifeq "$(GhcVersion)" "6.12.2" -compiler/hsSyn/HsLit_HC_OPTS += -fomit-interface-pragmas -endif - # LibFFI.hs #includes ffi.h compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS) # On Windows it seems we also need to link directly to libffi diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 3e9ab43579..f4ad61757f 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -443,8 +443,8 @@ linkExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: SrcSpan -> Message -> IO a -dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) +dieWith :: SrcSpan -> MsgDoc -> IO a +dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index f467c7ada3..dedc9ceb2f 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -36,12 +36,7 @@ import Control.Monad ( when ) import Foreign.C import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) -#if __GLASGOW_HASKELL__ >= 703 -import GHC.IO.Encoding (getFileSystemEncoding) -#else -import GHC.IO.Encoding (TextEncoding, fileSystemEncoding) -#endif -import qualified GHC.Foreign as GHC +import System.Posix.Internals ( CFilePath, withFilePath ) import System.FilePath ( dropExtension ) @@ -49,21 +44,10 @@ import System.FilePath ( dropExtension ) -- RTS Linker Interface -- --------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ < 703 -getFileSystemEncoding :: IO TextEncoding -getFileSystemEncoding = return fileSystemEncoding -#endif - --- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page -withFileCString :: FilePath -> (CString -> IO a) -> IO a -withFileCString fp f = do - enc <- getFileSystemEncoding - GHC.withCString enc fp f - insertSymbol :: String -> String -> Ptr a -> IO () insertSymbol obj_name key symbol = let str = prefixUnderscore key - in withFileCString obj_name $ \c_obj_name -> + in withFilePath obj_name $ \c_obj_name -> withCAString str $ \c_str -> c_insertSymbol c_obj_name c_str symbol @@ -99,7 +83,7 @@ loadDLL str0 = do str | isWindowsHost = dropExtension str0 | otherwise = str0 -- - maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll + maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr then return Nothing else do str <- peekCString maybe_errmsg @@ -107,19 +91,19 @@ loadDLL str0 = do loadArchive :: String -> IO () loadArchive str = do - withFileCString str $ \c_str -> do + withFilePath str $ \c_str -> do r <- c_loadArchive c_str when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) loadObj :: String -> IO () loadObj str = do - withFileCString str $ \c_str -> do + withFilePath str $ \c_str -> do r <- c_loadObj c_str when (r == 0) (panic ("loadObj " ++ show str ++ ": failed")) unloadObj :: String -> IO () unloadObj str = - withFileCString str $ \c_str -> do + withFilePath str $ \c_str -> do r <- c_unloadObj c_str when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) @@ -132,12 +116,12 @@ resolveObjs = do -- Foreign declarations to RTS entry points which does the real work; -- --------------------------------------------------------------------------- -foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString +foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString foreign import ccall unsafe "initLinker" initObjLinker :: IO () -foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO () +foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO () foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) -foreign import ccall unsafe "loadArchive" c_loadArchive :: CString -> IO Int -foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int -foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int +foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int +foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int +foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int \end{code} diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f521ee6b06..f140c8fb09 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -72,7 +72,7 @@ import Data.Array.Base import Data.Ix import Data.List import qualified Data.Sequence as Seq -import Data.Monoid +import Data.Monoid (mappend) import Data.Sequence (viewl, ViewL(..)) import Foreign.Safe import System.IO.Unsafe diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index f294a1b8c5..5318c5be49 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -48,25 +48,25 @@ import GHC.Exts ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName] +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName) +convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) convertToHsExpr loc e = initCvt loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName) +convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) convertToPat loc p = initCvt loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } +newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a } -- Push down the source location; -- Can fail, with a single error message @@ -85,13 +85,13 @@ instance Monad CvtM where Left err -> Left err Right v -> unCvtM (k v) loc -initCvt :: SrcSpan -> CvtM a -> Either Message a +initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a initCvt loc (CvtM m) = m loc force :: a -> CvtM () force a = a `seq` return () -failWith :: Message -> CvtM a +failWith :: MsgDoc -> CvtM a failWith m = CvtM (\_ -> Left m) getL :: CvtM SrcSpan @@ -195,7 +195,7 @@ cvtDec (InstanceD ctxt ty decs) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' - ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') } + ; returnL $ InstD (ClsInstDecl inst_ty' binds' sigs' ats') } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -213,26 +213,28 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = cons', tcdDerivs = derivs' }) } + ; returnL $ InstD $ FamInstDecl $ + TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = cons', tcdDerivs = derivs' } } cvtDec (NewtypeInstD ctxt tc tys constr derivs) = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' - , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing - , tcdCons = [con'], tcdDerivs = derivs' }) - } + ; returnL $ InstD $ FamInstDecl $ + TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing + , tcdCons = [con'], tcdDerivs = derivs' } } cvtDec (TySynInstD tc tys rhs) = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') } + ; returnL $ InstD $ FamInstDecl $ + TySynonym tc' tvs' tys' rhs' } ---------------- -cvt_ci_decs :: Message -> [TH.Dec] +cvt_ci_decs :: MsgDoc -> [TH.Dec] -> CvtM (LHsBinds RdrName, [LSig RdrName], [LTyClDecl RdrName]) @@ -304,7 +306,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) is_bind decl = Right decl -mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message +mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc mkBadDecMsg doc bads = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -437,7 +439,7 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) -- Declarations --------------------------------------------------- -cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) cvtLocalDecs doc ds | null ds = return EmptyLocalBinds diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index d4463632af..e6d369c519 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,9 +18,11 @@ module HsDecls ( isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, isFamInstDecl, tcdName, tyClDeclTyVars, countTyClDecls, + -- ** Instance declarations InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), - instDeclATs, + FamInstDecl, LFamInstDecl, instDeclFamInsts, + -- ** Standalone deriving declarations DerivDecl(..), LDerivDecl, -- ** @RULE@ declarations @@ -128,12 +130,15 @@ data HsGroup id = HsGroup { hs_valds :: HsValBinds id, - hs_tyclds :: [[LTyClDecl id]], + hs_tyclds :: [[LTyClDecl id]], -- A list of mutually-recursive groups + -- No family-instances here; they are in hs_instds -- Parser generates a singleton list; -- renamer does dependency analysis - hs_instds :: [LInstDecl id], + hs_instds :: [LInstDecl id], + -- Both class and family instance declarations in here + hs_derivds :: [LDerivDecl id], hs_fixds :: [LFixitySig id], @@ -154,7 +159,8 @@ emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } -emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], +emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], + hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], hs_valds = error "emptyGroup hs_valds: Can't happen", @@ -430,8 +436,9 @@ Interface file code: -- In both cases, 'tcdVars' collects all variables we need to quantify over. type LTyClDecl name = Located (TyClDecl name) -type TyClGroup name = [LTyClDecl name] -- this is used in TcTyClsDecls to represent +type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent -- strongly connected components of decls + -- No familiy instances in here -- | A type or class declaration. data TyClDecl name @@ -504,7 +511,7 @@ data TyClDecl name tcdMeths :: LHsBinds name, -- ^ Default methods tcdATs :: [LTyClDecl name], -- ^ Associated types; ie -- only 'TyFamily' - tcdATDefs :: [LTyClDecl name], -- ^ Associated type defaults; ie + tcdATDefs :: [LFamInstDecl name], -- ^ Associated type defaults; ie -- only 'TySynonym' tcdDocs :: [LDocDecl] -- ^ Haddock docs } @@ -602,15 +609,14 @@ tyClDeclTyVars (ForeignType {}) = [] \end{code} \begin{code} -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int) - -- class, synonym decls, data, newtype, family decls, family instances +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, -- excluding... count isDataTy decls, -- ...family... count isNewTy decls, -- ...instances - count isFamilyDecl decls, - count isFamInstDecl decls) + count isFamilyDecl decls) where isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True isDataTy _ = False @@ -802,8 +808,8 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs , con_res = ResTyH98, con_doc = doc }) = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] where - ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2] - ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys) + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc (unLoc con) : map ppr tys) ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs @@ -833,18 +839,25 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG \begin{code} type LInstDecl name = Located (InstDecl name) -data InstDecl name - = InstDecl (LHsType name) -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. - (LHsBinds name) - [LSig name] -- User-supplied pragmatic info - [LTyClDecl name]-- Associated types (ie, 'TyData' and - -- 'TySynonym' only) +type LFamInstDecl name = Located (FamInstDecl name) +type FamInstDecl name = TyClDecl name -- Type or data family instance + +data InstDecl name -- Both class and family instances + = ClsInstDecl + (LHsType name) -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + (LHsBinds name) + [LSig name] -- User-supplied pragmatic info + [LFamInstDecl name] -- Family instances for associated types + + | FamInstDecl -- type/data family instance + (FamInstDecl name) + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (InstDecl inst_ty binds sigs ats) + ppr (ClsInstDecl inst_ty binds sigs ats) | null sigs && null ats && isEmptyBag binds -- No "where" part = top_matter @@ -855,10 +868,16 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where where top_matter = ptext (sLit "instance") <+> ppr inst_ty + ppr (FamInstDecl decl) = ppr decl + -- Extract the declarations of associated types from an instance --- -instDeclATs :: [LInstDecl name] -> [LTyClDecl name] -instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats] + +instDeclFamInsts :: [LInstDecl name] -> [LTyClDecl name] +instDeclFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one (L _ (ClsInstDecl _ _ _ fam_insts)) = fam_insts + do_one (L loc (FamInstDecl fam_inst)) = [L loc fam_inst] \end{code} %************************************************************************ @@ -1096,7 +1115,7 @@ data VectDecl name | HsVectInstIn -- pre type-checking (always SCALAR) (LHsType name) | HsVectInstOut -- post type-checking (always SCALAR) - Instance + ClsInst deriving (Data, Typeable) lvectDeclName :: NamedThing name => LVectDecl name -> Name diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 5a18fc6574..1dd3c83f31 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -379,7 +379,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc -ppr_expr (HsVar v) = pprHsVar v +ppr_expr (HsVar v) = pprPrefixOcc v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit @@ -407,7 +407,7 @@ ppr_expr (OpApp e1 op _ e2) = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]] + = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e @@ -420,7 +420,7 @@ ppr_expr (SectionL expr op) pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) 4 (hsep [pp_expr, ptext (sLit "x_ )")]) - pp_infixly v = (sep [pp_expr, pprHsInfix v]) + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) ppr_expr (SectionR op expr) = case unLoc op of @@ -431,7 +431,7 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) 4 ((<>) pp_expr rparen) - pp_infixly v = sep [pprHsInfix v, pp_expr] + pp_infixly v = sep [pprInfixOcc v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs)) @@ -541,7 +541,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow] ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) - = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]] + = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] ppr_expr (HsArrForm op _ args) = hang (ptext (sLit "(|") <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)")) @@ -928,10 +928,11 @@ data StmtLR idL idR , recS_mfix_fn :: SyntaxExpr idR -- The mfix function -- These fields are only valid after typechecking - , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 with - -- recS_rec_ids, and are the - -- expressions that should be returned by - -- the recursion. + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. -- They may not quite be the Ids themselves, -- because the Id may be *polymorphic*, but -- the returned thing has to be *monomorphic*, diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index 6666243264..86032f5829 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -1,15 +1,8 @@ \begin{code} {-# LANGUAGE KindSignatures #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module HsExpr where -import SrcLoc ( Located ) +import SrcLoc ( Located ) import Outputable ( SDoc, OutputableBndr ) import {-# SOURCE #-} HsPat ( LPat ) @@ -34,17 +27,17 @@ type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a pprLExpr :: (OutputableBndr i) => - LHsExpr i -> SDoc + LHsExpr i -> SDoc pprExpr :: (OutputableBndr i) => - HsExpr i -> SDoc + HsExpr i -> SDoc pprSplice :: (OutputableBndr i) => - HsSplice i -> SDoc + HsSplice i -> SDoc pprPatBind :: (OutputableBndr b, OutputableBndr i) => - LPat b -> GRHSs i -> SDoc + LPat b -> GRHSs i -> SDoc pprFunBind :: (OutputableBndr idL, OutputableBndr idR) => - idL -> Bool -> MatchGroup idR -> SDoc + idL -> Bool -> MatchGroup idR -> SDoc \end{code} diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 01890b6c95..ee75414d4c 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -57,7 +57,7 @@ simpleImportDecl mn = ImportDecl { \end{code} \begin{code} -instance (Outputable name) => Outputable (ImportDecl name) where +instance (OutputableBndr name) => Outputable (ImportDecl name) where ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit @@ -134,12 +134,12 @@ ieNames (IEDocNamed _ ) = [] \end{code} \begin{code} -instance (Outputable name) => Outputable (IE name) where - ppr (IEVar var) = pprHsVar var +instance (OutputableBndr name, Outputable name) => Outputable (IE name) where + ppr (IEVar var) = pprPrefixOcc var ppr (IEThingAbs thing) = ppr thing ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] ppr (IEThingWith thing withs) - = pprHsVar thing <> parens (fsep (punctuate comma (map pprHsVar withs))) + = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs))) ppr (IEModuleContents mod') = ptext (sLit "module") <+> ppr mod' ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">") diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index b76ff4b0f5..accb3ddc14 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -195,6 +195,19 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 \end{code} +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + Note [Promotions (HsTyVar)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ HsTyVar: A name in a type or kind. diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 234791d9fc..293f5b05a6 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -68,7 +68,7 @@ module HsUtils( collectLStmtBinders, collectStmtBinders, collectSigTysFromPats, collectSigTysFromPat, - hsTyClDeclBinders, hsTyClDeclsBinders, + hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders, hsForeignDeclsBinders, hsGroupBinders, -- Collecting implicit binders @@ -233,7 +233,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr - , recS_bind_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr, recS_later_rets = [] , recS_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -619,29 +619,33 @@ hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls] hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclATs inst_decls ++ concat tycl_decls - , L _ n <- hsTyClDeclBinders d] + = [n | d <- instDeclFamInsts inst_decls ++ concat tycl_decls + , L _ n <- hsLTyClDeclBinders d] -hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] +hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name] -- ^ Returns all the /binding/ names of the decl, along with their SrcLocs. -- The first one is guaranteed to be the name of the decl. For record fields -- mentioned in multiple constructors, the SrcLoc will be from the first -- occurence. We use the equality to filter out duplicate field names +hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d -hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name] -hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name] +hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name] +hsTyClDeclBinders (TyFamily {tcdLName = name}) = [name] +hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name] -hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})) +hsTyClDeclBinders (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}) = cls_name : - concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] + concatMap hsLTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] -hsTyClDeclBinders (L _ (TySynonym {tcdLName = name, tcdTyPats = mb_pats })) +hsTyClDeclBinders (TySynonym {tcdLName = name, tcdTyPats = mb_pats }) | isJust mb_pats = [] | otherwise = [name] -- See Note [Binders in family instances] -hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })) +hsTyClDeclBinders (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats }) | isJust mb_pats = hsConDeclsBinders cons | otherwise = tc_name : hsConDeclsBinders cons -- See Note [Binders in family instances] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 792421daa5..d821c13fdc 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -59,7 +59,6 @@ import Data.Word import Data.Array import Data.IORef import Control.Monad -import System.Time ( ClockTime(..) ) -- --------------------------------------------------------------------------- @@ -77,7 +76,7 @@ readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> TcRnIf a b ModIface readBinIface checkHiWay traceBinIFaceReading hi_path = do ncu <- mkNameCacheUpdater - dflags <- getDOpts + dflags <- getDynFlags liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath @@ -618,16 +617,6 @@ instance Binary AvailInfo where ac <- get bh return (AvailTC ab ac) - --- where should this be located? -instance Binary ClockTime where - put_ bh (TOD x y) = put_ bh x >> put_ bh y - - get bh = do - x <- get bh - y <- get bh - return $ TOD x y - instance Binary Usage where put_ bh usg@UsagePackageModule{} = do putByte bh 0 @@ -1391,13 +1380,12 @@ instance Binary IfaceDecl where put_ bh a6 put_ bh a7 - put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do + put_ bh (IfaceSyn a1 a2 a3 a4) = do putByte bh 3 put_ bh (occNameFS a1) put_ bh a2 put_ bh a3 put_ bh a4 - put_ bh a5 put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do putByte bh 4 @@ -1408,6 +1396,13 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 5 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 get bh = do h <- getByte bh @@ -1432,10 +1427,9 @@ instance Binary IfaceDecl where a2 <- get bh a3 <- get bh a4 <- get bh - a5 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceSyn occ a2 a3 a4 a5) - _ -> do a1 <- get bh + return (IfaceSyn occ a2 a3 a4) + 4 -> do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh @@ -1444,9 +1438,15 @@ instance Binary IfaceDecl where a7 <- get bh occ <- return $! mkOccNameFS clsName a2 return (IfaceClass a1 occ a3 a4 a5 a6 a7) + _ -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceAxiom occ a2 a3 a4) -instance Binary IfaceInst where - put_ bh (IfaceInst cls tys dfun flag orph) = do +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do put_ bh cls put_ bh tys put_ bh dfun @@ -1458,18 +1458,20 @@ instance Binary IfaceInst where dfun <- get bh flag <- get bh orph <- get bh - return (IfaceInst cls tys dfun flag orph) + return (IfaceClsInst cls tys dfun flag orph) instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys tycon) = do + put_ bh (IfaceFamInst fam tys name orph) = do put_ bh fam put_ bh tys - put_ bh tycon + put_ bh name + put_ bh orph get bh = do - fam <- get bh - tys <- get bh - tycon <- get bh - return (IfaceFamInst fam tys tycon) + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) instance Binary OverlapFlag where put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b @@ -1486,14 +1488,14 @@ instance Binary OverlapFlag where instance Binary IfaceConDecls where put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfOpenDataTyCon = putByte bh 1 + put_ bh IfDataFamTyCon = putByte bh 1 put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c get bh = do h <- getByte bh case h of 0 -> get bh >>= (return . IfAbstractTyCon) - 1 -> return IfOpenDataTyCon + 1 -> return IfDataFamTyCon 2 -> get bh >>= (return . IfDataTyCon) _ -> get bh >>= (return . IfNewTyCon) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 612b098c2f..75b8d91881 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -12,13 +12,12 @@ -- for details module BuildTyCl ( - buildSynTyCon, + buildSynTyCon, buildAlgTyCon, buildDataCon, - buildPromotedDataTyCon, TcMethInfo, buildClass, - distinctAbstractTyConRhs, totallyAbstractTyConRhs, - mkNewTyConRhs, mkDataTyConRhs, + distinctAbstractTyConRhs, totallyAbstractTyConRhs, + mkNewTyConRhs, mkDataTyConRhs, newImplicitBinder ) where @@ -35,13 +34,11 @@ import MkId import Class import TyCon import Type -import Kind ( promoteType, isPromotableType ) import Coercion import TcRnMonad import Util ( isSingleton ) import Outputable -import Unique ( getUnique ) \end{code} @@ -49,69 +46,28 @@ import Unique ( getUnique ) ------------------------------------------------------ buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs - -> Kind -- ^ Kind of the RHS - -> TyConParent - -> Maybe (TyCon, [Type]) -- ^ family instance if applicable + -> Kind -- ^ Kind of the RHS + -> TyConParent -> TcRnIf m n TyCon -buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family - | Just fam_inst_info <- mb_family - = ASSERT( isNoParent parent ) - fixM $ \ tycon_rec -> do - { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec - ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) } - - | otherwise +buildSynTyCon tc_name tvs rhs rhs_kind parent = return (mkSynTyCon tc_name kind tvs rhs parent) where kind = mkPiKinds tvs rhs_kind ------------------------------------------------------ -buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables adn type variables - -> ThetaType -- ^ Stupid theta +buildAlgTyCon :: Name + -> [TyVar] -- ^ Kind variables and type variables + -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag - -> Bool -- ^ True <=> was declared in GADT syntax + -> Bool -- ^ True <=> was declared in GADT syntax -> TyConParent - -> Maybe (TyCon, [Type]) -- ^ family instance if applicable - -> TcRnIf m n TyCon - -buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn - parent mb_family - | Just fam_inst_info <- mb_family - = -- We need to tie a knot as the coercion of a data instance depends - -- on the instance representation tycon and vice versa. - ASSERT( isNoParent parent ) - fixM $ \ tycon_rec -> do - { fam_parent <- mkFamInstParentInfo tc_name ktvs fam_inst_info tycon_rec - ; return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs - fam_parent is_rec gadt_syn) } - - | otherwise - = return (mkAlgTyCon tc_name kind ktvs stupid_theta rhs - parent is_rec gadt_syn) - where kind = mkPiKinds ktvs liftedTypeKind - --- | If a family tycon with instance types is given, the current tycon is an --- instance of that family and we need to --- --- (1) create a coercion that identifies the family instance type and the --- representation type from Step (1); ie, it is of the form --- `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion, --- `F' the family tycon and `R' the (derived) representation tycon, --- and --- (2) produce a `TyConParent' value containing the parent and coercion --- information. --- -mkFamInstParentInfo :: Name -> [TyVar] - -> (TyCon, [Type]) - -> TyCon - -> TcRnIf m n TyConParent -mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon - = do { -- Create the coercion - ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc - ; let co_tycon = mkFamInstCo co_tycon_name tvs - family instTys rep_tycon - ; return $ FamInstTyCon family instTys co_tycon } - + -> TyCon + +buildAlgTyCon tc_name ktvs stupid_theta rhs is_rec gadt_syn parent + = mkAlgTyCon tc_name kind ktvs stupid_theta rhs parent is_rec gadt_syn + where + kind = mkPiKinds ktvs liftedTypeKind + ------------------------------------------------------ distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs distinctAbstractTyConRhs = AbstractTyCon True @@ -225,11 +181,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfType pred `intersectVarSet` arg_tyvars - -buildPromotedDataTyCon :: DataCon -> TyCon -buildPromotedDataTyCon dc = ASSERT ( isPromotableType ty ) - mkPromotedDataTyCon dc (getName dc) (getUnique dc) (promoteType ty) - where ty = dataConUserType dc \end{code} diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index 611228e567..5e4a7092bf 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -41,7 +41,9 @@ fingerprintDynFlags DynFlags{..} nameio = -- -i, -osuf, -hcsuf, -hisuf, -odir, -hidir, -stubdir, -o, -ohi paths = (map normalise importPaths, [ objectSuf, hcSuf, hiSuf ], - [ objectDir, hiDir, stubDir, outputFile, outputHi ]) + [ objectDir, hiDir, stubDir, outputHi ]) + -- NB. not outputFile, we don't want "ghc --make M -o <file>" + -- to force recompilation when <file> changes. -- -fprof-auto etc. prof = if opt_SccProfilingOn then fromEnum profAuto else 0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 6f59e38736..fd8b361b3d 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -20,13 +20,13 @@ module IfaceSyn ( IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), -- Misc - ifaceDeclSubBndrs, visibleIfConDecls, + ifaceDeclImplicitBndrs, visibleIfConDecls, -- Free Names - freeNamesIfDecl, freeNamesIfRule, + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, -- Pretty printing pprIfaceExpr, pprIfaceDeclHead @@ -70,26 +70,19 @@ data IfaceDecl | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data info + ifCons :: IfaceConDecls, -- Includes new/data/data family info ifRec :: RecFlag, -- Recursive or not? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax - ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) - -- Just <=> instance of family - -- Invariant: - -- ifCons /= IfOpenDataTyCon - -- for family instances + ifAxiom :: Maybe IfExtName -- The axiom, for a newtype, + -- or data/newtype family instance } | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn - -- Nothing for an open family - ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) - -- Just <=> instance of family - -- Invariant: ifOpenSyn == False - -- for family instances + ifSynRhs :: Maybe IfaceType -- Just rhs for an ordinary synonyn + -- Nothing for an type family declaration } | IfaceClass { ifCtxt :: IfaceContext, -- Context... @@ -102,6 +95,11 @@ data IfaceDecl -- with the class recursive? } + | IfaceAxiom { ifName :: OccName -- Axiom name + , ifTyVars :: [IfaceTvBndr] -- Axiom tyvars + , ifLHS :: IfaceType -- Axiom LHS + , ifRHS :: IfaceType } -- and RHS + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move -- beyond .NET ifExtName :: Maybe FastString } @@ -123,13 +121,13 @@ data IfaceATDefault = IfaceATD [IfaceTvBndr] [IfaceType] IfaceType data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon - | IfOpenDataTyCon -- Open data family - | IfDataTyCon [IfaceConDecl] -- data type decls - | IfNewTyCon IfaceConDecl -- newtype decls + | IfDataFamTyCon -- Data family + | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfNewTyCon IfaceConDecl -- Newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls IfOpenDataTyCon = [] +visibleIfConDecls IfDataFamTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] @@ -147,12 +145,12 @@ data IfaceConDecl ifConStricts :: [HsBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys -data IfaceInst - = IfaceInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See Note [Orphans] +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See Note [Orphans] -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -161,9 +159,10 @@ data IfaceInst -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst - = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types - , ifFamInstTyCon :: IfaceTyCon -- Instance decl + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst } data IfaceRule @@ -175,7 +174,7 @@ data IfaceRule ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, ifRuleAuto :: Bool, - ifRuleOrph :: Maybe OccName -- Just like IfaceInst + ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst } data IfaceAnnotation @@ -375,38 +374,34 @@ See [http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationA -- ----------------------------------------------------------------------------- -- Utils on IfaceSyn -ifaceDeclSubBndrs :: IfaceDecl -> [OccName] +ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon +-- See Note [Implicit TyThings] in HscTypes -- N.B. the set of names returned here *must* match the set of -- TyThings returned by HscTypes.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. -ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] +ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] -- Newtype -ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ }), - ifFamInst = famInst}) - = -- implicit coerion and (possibly) family instance coercion - (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ + IfCon { ifConOcc = con_occ })}) + = -- implicit newtype coercion + (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit -- data constructor and worker (newtypes don't have a wrapper) [con_occ, mkDataConWorkerOcc con_occ] -ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfDataTyCon cons, - ifFamInst = famInst}) - = -- (possibly) family instance coercion; - -- there is no implicit coercion for non-newtypes - famInstCo famInst tc_occ - -- for each data constructor in order, - -- data constructor, worker, and (possibly) wrapper - ++ concatMap dc_occs cons +ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ, + ifCons = IfDataTyCon cons }) + = -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper + concatMap dc_occs cons where dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] @@ -418,7 +413,7 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, has_wrapper = ifConWrapper con_decl -- This is the reason for -- having the ifConWrapper field! -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, +ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ifSigs = sigs, ifATs = ats }) = -- (possibly) newtype coercion co_occs ++ @@ -441,16 +436,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, dc_occ = mkClassDataConOcc cls_tc_occ is_newtype = n_sigs + n_ctxt == 1 -- Sigh -ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, - ifFamInst = famInst}) - = famInstCo famInst tc_occ - -ifaceDeclSubBndrs _ = [] - --- coercion for data/newtype family instances -famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName] -famInstCo Nothing _ = [] -famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] +ifaceDeclImplicitBndrs _ = [] ----------------------------- Printing IfaceDecl ------------------------------ @@ -468,10 +454,9 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty, - ifFamInst = mbFamInst}) + ifSynRhs = Just mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) + 4 (vcat [equals <+> ppr mono_ty]) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = Nothing, ifSynKind = kind }) @@ -480,14 +465,14 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifFamInst = mbFamInst}) + ifRec = isrec, ifAxiom = mbAxiom}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 4 (vcat [pprRec isrec, pp_condecls tycon condecls, - pprFamily mbFamInst]) + pprAxiom mbAxiom]) where pp_nd = case condecls of IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis) - IfOpenDataTyCon -> ptext (sLit "data family") + IfDataFamTyCon -> ptext (sLit "data family") IfDataTyCon _ -> ptext (sLit "data") IfNewTyCon _ -> ptext (sLit "newtype") @@ -499,12 +484,17 @@ pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, sep (map ppr ats), sep (map ppr sigs)]) +pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars, + ifLHS = lhs, ifRHS = rhs}) + = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars) + 2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs) + pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec -pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc -pprFamily Nothing = ptext (sLit "FamilyInstance: none") -pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst +pprAxiom :: Maybe Name -> SDoc +pprAxiom Nothing = ptext (sLit "FamilyInstance: none") +pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty @@ -522,7 +512,7 @@ pprIfaceDeclHead context thing tyvars pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ (IfAbstractTyCon {}) = empty -pp_condecls _ IfOpenDataTyCon = empty +pp_condecls _ IfDataFamTyCon = empty pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) (map (pprIfaceConDecl tc) cs)) @@ -571,8 +561,8 @@ instance Outputable IfaceRule where ptext (sLit "=") <+> ppr rhs]) ] -instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, +instance Outputable IfaceClsInst where + ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag, ifInstCls = cls, ifInstTys = mb_tcs}) = hang (ptext (sLit "instance") <+> ppr flag <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) @@ -580,10 +570,10 @@ instance Outputable IfaceInst where instance Outputable IfaceFamInst where ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstTyCon = tycon_id}) + ifFamInstAxiom = tycon_ax}) = hang (ptext (sLit "family instance") <+> ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) - 2 (equals <+> ppr tycon_id) + 2 (equals <+> ppr tycon_ax) ppr_rough :: Maybe IfaceTyCon -> SDoc ppr_rough Nothing = dot @@ -741,13 +731,12 @@ freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& - freeNamesIfTcFam (ifFamInst d) &&& + maybe emptyNameSet unitNameSet (ifAxiom d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfSynRhs (ifSynRhs d) &&& - freeNamesIfTcFam (ifFamInst d) &&& freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we -- return names in the kind signature freeNamesIfDecl d@IfaceClass{} = @@ -755,6 +744,10 @@ freeNamesIfDecl d@IfaceClass{} = freeNamesIfContext (ifCtxt d) &&& fnList freeNamesIfAT (ifATs d) &&& fnList freeNamesIfClsSig (ifSigs d) +freeNamesIfDecl d@IfaceAxiom{} = + freeNamesIfTvBndrs (ifTyVars d) &&& + freeNamesIfType (ifLHS d) &&& + freeNamesIfType (ifRHS d) freeNamesIfIdDetails :: IfaceIdDetails -> NameSet freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc @@ -765,12 +758,6 @@ freeNamesIfSynRhs :: Maybe IfaceType -> NameSet freeNamesIfSynRhs (Just ty) = freeNamesIfType ty freeNamesIfSynRhs Nothing = emptyNameSet -freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet -freeNamesIfTcFam (Just (tc,tys)) = - freeNamesIfTc tc &&& fnList freeNamesIfType tys -freeNamesIfTcFam Nothing = - emptyNameSet - freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType @@ -902,6 +889,12 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName -- helpers (&&&) :: NameSet -> NameSet -> NameSet diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 7df2f49778..107c24c94f 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -167,7 +167,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr Message ModIface) + -> IfM lcl (MaybeErr MsgDoc ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -188,7 +188,7 @@ loadInterface doc_str mod from ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; dflags <- getDOpts + ; dflags <- getDynFlags ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { Just iface -> return (Succeeded iface) ; -- Already loaded @@ -236,7 +236,7 @@ loadInterface doc_str mod from -- -- The main thing is to add the ModIface to the PIT, but -- we also take the - -- IfaceDecls, IfaceInst, IfaceFamInst, IfaceRules, IfaceVectInfo + -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, IfaceVectInfo -- out of the ModIface and put them into the big EPS pools -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined @@ -294,7 +294,7 @@ loadInterface doc_str mod from }}}} wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr Message IsBootInterface + -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile dflags eps mod from = case from of @@ -372,7 +372,7 @@ loadDecl ignore_prags mod (_version, decl) -- the names associated with the decl main_name <- lookupOrig mod (ifName decl) -- ; traceIf (text "Loading decl for " <> ppr main_name) - ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl) + ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclImplicitBndrs decl) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -402,7 +402,7 @@ loadDecl ignore_prags mod (_version, decl) -- (where the "MkT" is the *Name* associated with MkT, etc.) -- -- We do this by mapping the implict_names to the associated - -- TyThings. By the invariant on ifaceDeclSubBndrs and + -- TyThings. By the invariant on ifaceDeclImplicitBndrs and -- implicitTyThings, we can use getOccName on the implicit -- TyThings to make this association: each Name's OccName should -- be the OccName of exactly one implictTyThing. So the key is @@ -472,7 +472,7 @@ bumpDeclStats name findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -489,7 +489,7 @@ findAndReadIface doc_str mod hi_boot_file nest 4 (ptext (sLit "reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface - ; dflags <- getDOpts + ; dflags <- getDynFlags ; if mod == gHC_PRIM then return (Succeeded (ghcPrimIface, "<built in interface for GHC.Prim>")) @@ -526,7 +526,7 @@ findAndReadIface doc_str mod hi_boot_file }} ; err -> do { traceIf (ptext (sLit "...not found")) - ; dflags <- getDOpts + ; dflags <- getDynFlags ; return (Failed (cannotFindInterface dflags (moduleName mod) err)) } } @@ -537,7 +537,7 @@ findAndReadIface doc_str mod hi_boot_file \begin{code} readIface :: Module -> FilePath -> IsBootInterface - -> TcRnIf gbl lcl (MaybeErr Message ModIface) + -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -794,7 +794,7 @@ badIfaceFile file err = vcat [ptext (sLit "Bad interface file:") <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> Message +hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc hiModuleNameMismatchWarn requested_mod read_mod = withPprStyle defaultUserStyle $ -- we want the Modules below to be qualified with package names, diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 2125181e6d..9904042fe0 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -68,6 +68,7 @@ import CoreFVs import Class import Kind import TyCon +import Coercion ( coAxiomSplitLHS ) import DataCon import Type import TcType @@ -110,7 +111,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.IORef import System.FilePath -import System.Directory (getModificationTime) \end{code} @@ -261,8 +261,9 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info - -- Check if we are in Safe Inference mode but we failed to pass - -- the muster + + -- Check if we are in Safe Inference mode + -- but we failed to pass the muster ; safeMode = if safeInferOn dflags && not safeInf then Sf_None else safeHaskell dflags @@ -361,7 +362,7 @@ mkIface_ hsc_env maybe_old_fingerprint deliberatelyOmitted :: String -> a deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) - ifFamInstTcName = ifaceTyConName . ifFamInstTyCon + ifFamInstTcName = ifFamInstFam flattenVectInfo (VectInfo { vectInfoVar = vVar , vectInfoTyCon = vTyCon @@ -430,7 +431,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- see IfaceDeclABI below. declABI :: IfaceDecl -> IfaceDeclABI declABI decl = (this_mod, decl, extras) - where extras = declExtras fix_fn non_orph_rules non_orph_insts decl + where extras = declExtras fix_fn non_orph_rules non_orph_insts + non_orph_fis decl edges :: [(IfaceDeclABI, Unique, [Unique])] edges = [ (abi, getUnique (ifName decl), out) @@ -451,7 +453,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls parent_map :: OccEnv OccName parent_map = foldr extend emptyOccEnv new_decls where extend d env = - extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ] + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] where n = ifName d -- strongly-connected groups of declarations, in dependency order @@ -473,8 +475,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls | otherwise = ASSERT2( isExternalName name, ppr name ) let hash | nameModule name /= this_mod = global_hash_fn name - | otherwise = - snd (lookupOccEnv local_env (getOccName name) + | otherwise = snd (lookupOccEnv local_env (getOccName name) `orElse` pprPanic "urk! lookup local fingerprint" (ppr name)) -- (undefined,fingerprint0)) -- This panic indicates that we got the dependency @@ -484,8 +485,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- pprTraces below, run the compile again, and inspect -- the output and the generated .hi file with -- --show-iface. - in - put_ bh hash + in put_ bh hash -- take a strongly-connected group of declarations and compute -- its fingerprint. @@ -530,7 +530,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -> IO (OccEnv (OccName,Fingerprint)) extend_hash_env env0 (hash,d) = do let - sub_bndrs = ifaceDeclSubBndrs d + sub_bndrs = ifaceDeclImplicitBndrs d fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ) -- sub_fps <- mapM fp_sub_bndr sub_bndrs @@ -561,7 +561,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods orphan_hash <- computeFingerprint (mk_put_name local_env) - (map ifDFun orph_insts, orph_rules, fam_insts) + (map ifDFun orph_insts, orph_rules, orph_fis) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. @@ -594,8 +594,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - flag abi hash mod_hash <- computeFingerprint putNameLiterally (map fst sorted_decls, - export_hash, - orphan_hash, + export_hash, -- includes orphan_hash mi_warns iface0, mi_vect_info iface0) @@ -619,8 +618,10 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls mi_exp_hash = export_hash, mi_orphan_hash = orphan_hash, mi_flag_hash = flag_hash, - mi_orphan = not (null orph_rules && null orph_insts - && null (ifaceVectInfoVar (mi_vect_info iface0))), + mi_orphan = not ( null orph_rules + && null orph_insts + && null orph_fis + && isNoIfaceVectInfo (mi_vect_info iface0)), mi_finsts = not . null $ mi_fam_insts iface0, mi_decls = sorted_decls, mi_hash_fn = lookupOccEnv local_env } @@ -631,12 +632,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls this_mod = mi_module iface0 dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags - (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) - (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) - -- See Note [Orphans] in IfaceSyn - -- ToDo: shouldn't we be splitting fam_insts into orphans and - -- non-orphans? - fam_insts = mi_fam_insts iface0 + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) fix_fn = mi_fix_fn iface0 @@ -700,7 +698,7 @@ data IfaceDeclExtras | IfaceDataExtras Fixity -- Fixity of the tycon itself - [IfaceInstABI] -- Local instances of this tycon + [IfaceInstABI] -- Local class and family instances of this tycon -- See Note [Orphans] in IfaceSyn [(Fixity,[IfaceRule])] -- For each construcotr, fixity and RULES @@ -711,10 +709,16 @@ data IfaceDeclExtras -- See Note [Orphans] in IfaceSyn [(Fixity,[IfaceRule])] -- For each class method, fixity and RULES - | IfaceSynExtras Fixity + | IfaceSynExtras Fixity [IfaceInstABI] | IfaceOtherDeclExtras +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + abiDecl :: IfaceDeclABI -> IfaceDecl abiDecl (_, decl, _) = decl @@ -733,8 +737,8 @@ freeNamesDeclExtras (IfaceDataExtras _ insts subs) = unionManyNameSets (mkNameSet insts : map freeNamesSub subs) freeNamesDeclExtras (IfaceClassExtras _ insts subs) = unionManyNameSets (mkNameSet insts : map freeNamesSub subs) -freeNamesDeclExtras (IfaceSynExtras _) - = emptyNameSet +freeNamesDeclExtras (IfaceSynExtras _ insts) + = mkNameSet insts freeNamesDeclExtras IfaceOtherDeclExtras = emptyNameSet @@ -744,9 +748,9 @@ freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules) instance Outputable IfaceDeclExtras where ppr IfaceOtherDeclExtras = empty ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules - ppr (IfaceSynExtras fix) = ppr fix - ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, - ppr_id_extras_s stuff] + ppr (IfaceSynExtras fix finsts) = vcat [ppr fix, ppr finsts] + ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, + ppr_id_extras_s stuff] ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts, ppr_id_extras_s stuff] @@ -768,24 +772,26 @@ instance Binary IfaceDeclExtras where putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons put_ bh (IfaceClassExtras fix insts methods) = do putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods - put_ bh (IfaceSynExtras fix) = do - putByte bh 4; put_ bh fix + put_ bh (IfaceSynExtras fix finsts) = do + putByte bh 4; put_ bh fix; put_ bh finsts put_ bh IfaceOtherDeclExtras = do putByte bh 5 declExtras :: (OccName -> Fixity) -> OccEnv [IfaceRule] - -> OccEnv [IfaceInst] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] -> IfaceDecl -> IfaceDeclExtras -declExtras fix_fn rule_env inst_env decl +declExtras fix_fn rule_env inst_env fi_env decl = case decl of IfaceId{} -> IfaceIdExtras (fix_fn n) (lookupOccEnvL rule_env n) IfaceData{ifCons=cons} -> IfaceDataExtras (fix_fn n) - (map ifDFun $ lookupOccEnvL inst_env n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) (map (id_extras . ifConOcc) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs, ifATs=ats} -> IfaceClassExtras (fix_fn n) @@ -794,18 +800,14 @@ declExtras fix_fn rule_env inst_env decl -- Include instances of the associated types -- as well as instances of the class (Trac #5147) [id_extras op | IfaceClassOp op _ _ <- sigs] - IfaceSyn{} -> IfaceSynExtras (fix_fn n) + IfaceSyn{} -> IfaceSynExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) _other -> IfaceOtherDeclExtras where n = ifName decl id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ) at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl) --- --- When hashing an instance, we hash only the DFunId, because that --- depends on all the information about the instance. --- -type IfaceInstABI = IfExtName lookupOccEnvL :: OccEnv [v] -> OccName -> [v] lookupOccEnvL env k = lookupOccEnv env k `orElse` [] @@ -837,10 +839,10 @@ oldMD5 dflags bh = do return $! readHexFingerprint hash_str -} -instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg +instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg instOrphWarn unqual inst = mkWarnMsg (getSrcSpan inst) unqual $ - hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst) + hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg ruleOrphWarn unqual mod rule @@ -882,7 +884,7 @@ mkOrphMap get_key decls mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage] mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files = do { eps <- hscEPS hsc_env - ; mtimes <- mapM getModificationTime dependent_files + ; mtimes <- mapM getModificationUTCTime dependent_files ; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names ; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes) @@ -1330,7 +1332,7 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, usg_mtime = old_mtime } = liftIO $ handleIO handle $ do - new_mtime <- getModificationTime file + new_mtime <- getModificationUTCTime file return $ old_mtime /= new_mtime where handle = @@ -1419,9 +1421,7 @@ tyThingToIfaceDecl (ATyCon tycon) = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, ifSynRhs = syn_rhs, - ifSynKind = syn_ki, - ifFamInst = famInstToIface (tyConFamInst_maybe tycon) - } + ifSynKind = syn_ki } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1430,7 +1430,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} + ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) } | isForeignTyCon tycon = IfaceForeign { ifName = getOccName tycon, @@ -1448,7 +1448,7 @@ tyThingToIfaceDecl (ATyCon tycon) IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls DataFamilyTyCon {} = IfOpenDataTyCon + ifaceConDecls DataFamilyTyCon {} = IfDataFamTyCon ifaceConDecls (AbstractTyCon distinct) = IfAbstractTyCon distinct -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used @@ -1472,11 +1472,16 @@ tyThingToIfaceDecl (ATyCon tycon) to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec] - famInstToIface Nothing = Nothing - famInstToIface (Just (famTyCon, instTys)) = - Just (toIfaceTyCon famTyCon, map toIfaceType instTys) - -tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c) +tyThingToIfaceDecl (ACoAxiom ax) + = IfaceAxiom { ifName = name + , ifTyVars = tv_bndrs + , ifLHS = lhs + , ifRHS = rhs } + where + name = getOccName ax + tv_bndrs = toIfaceTvBndrs (coAxiomTyVars ax) + lhs = toIfaceType (coAxiomLHS ax) + rhs = toIfaceType (coAxiomRHS ax) tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier @@ -1527,11 +1532,11 @@ getFS :: NamedThing a => a -> FastString getFS x = occNameFS (getOccName x) -------------------------- -instanceToIfaceInst :: Instance -> IfaceInst -instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag, is_cls = cls_name, is_tcs = mb_tcs }) = ASSERT( cls_name == className cls ) - IfaceInst { ifDFun = dfun_name, + IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag, ifInstCls = cls_name, ifInstTys = map do_rough mb_tcs, @@ -1569,16 +1574,34 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst (FamInst { fi_tycon = tycon, - fi_fam = fam, - fi_tcs = mb_tcs }) - = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon - , ifFamInstFam = fam - , ifFamInstTys = map do_rough mb_tcs } +famInstToIfaceFamInst (FamInst { fi_axiom = axiom, + fi_fam = fam, + fi_tcs = mb_tcs }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = map do_rough mb_tcs + , ifFamInstOrph = orph } where do_rough Nothing = Nothing do_rough (Just n) = Just (toIfaceTyCon_name n) + fam_decl = tyConName . fst $ coAxiomSplitLHS axiom + mod = ASSERT( isExternalName (coAxiomName axiom) ) + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + lhs_names = filterNameSet is_local (orphNamesOfType (coAxiomLHS axiom)) + + orph | is_local fam_decl + = Just (nameOccName fam_decl) + + | not (isEmptyNameSet lhs_names) + = Just (nameOccName (head (nameSetToList lhs_names))) + + + | otherwise + = Nothing + -------------------------- toIfaceLetBndr :: Id -> IfaceLetBndr toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8a279ca3a1..6946752158 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -125,7 +125,7 @@ tcImportDecl name Succeeded thing -> return thing Failed err -> failWithTc err } -importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) +importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name @@ -436,31 +436,41 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifFamInst = mb_family }) + ifAxiom = mb_axiom_name }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; tycon <- fixM ( \ tycon -> do + ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt + ; parent' <- tc_parent tyvars mb_axiom_name ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; mb_fam_inst <- tcFamInst mb_family - ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec - gadt_syn parent mb_fam_inst - }) + ; return (buildAlgTyCon tc_name tyvars stupid_theta + cons is_rec gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } + where + tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent + tc_parent _ Nothing = return parent + tc_parent tyvars (Just ax_name) + = ASSERT( isNoParent parent ) + do { ax <- tcIfaceCoAxiom ax_name + ; let (fam_tc, fam_tys) = coAxiomSplitLHS ax + subst = zipTopTvSubst (coAxiomTyVars ax) (mkTyVarTys tyvars) + -- The subst matches the tyvar of the TyCon + -- with those from the CoAxiom. They aren't + -- necessarily the same, since the two may be + -- gotten from separate interface-file declarations + ; return (FamInstTyCon ax fam_tc (substTys subst fam_tys)) } tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynRhs = mb_rhs_ty, - ifSynKind = kind, ifFamInst = mb_family}) + ifSynKind = kind }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name ; rhs_kind <- tcIfaceType kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_syn_rhs mb_rhs_ty - ; fam_info <- tcFamInst mb_family - ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info - ; return (ATyCon tycon) - } + ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent + ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n tc_syn_rhs Nothing = return SynFamilyTyCon @@ -493,14 +503,10 @@ tc_iface_decl _parent ignore_prags ; return (op_name, dm, op_ty) } tc_at cls (IfaceAT tc_decl defs_decls) - = do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl + = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl defs <- mapM tc_iface_at_def defs_decls return (tc, defs) - tc_iface_tc_decl parent decl = do - ATyCon tc <- tc_iface_decl parent ignore_prags decl - return tc - tc_iface_at_def (IfaceATD tvs pat_tys ty) = bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 (\pats tys -> ATD tvs' pats tys noSrcSpan) @@ -517,17 +523,25 @@ tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0)) } -tcFamInst :: Maybe (IfaceTyCon, [IfaceType]) -> IfL (Maybe (TyCon, [Type])) -tcFamInst Nothing = return Nothing -tcFamInst (Just (fam, tys)) = do { famTyCon <- tcIfaceTyCon fam - ; insttys <- mapM tcIfaceType tys - ; return $ Just (famTyCon, insttys) } +tc_iface_decl _ _ (IfaceAxiom {ifName = tc_occ, ifTyVars = tv_bndrs, + ifLHS = lhs, ifRHS = rhs }) + = bindIfaceTyVars tv_bndrs $ \ tvs -> do + { tc_name <- lookupIfaceTop tc_occ + ; tc_lhs <- tcIfaceType lhs + ; tc_rhs <- tcIfaceType rhs + ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + , co_ax_name = tc_name + , co_ax_implicit = False + , co_ax_tvs = tvs + , co_ax_lhs = tc_lhs + , co_ax_rhs = tc_rhs } + ; return (ACoAxiom axiom) } tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon _ if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) - IfOpenDataTyCon -> return DataFamilyTyCon + IfDataFamTyCon -> return DataFamilyTyCon IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -561,7 +575,7 @@ tcIfaceDataCons tycon_name tycon _ if_cons ; let orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) univ_tyvars) - ; buildDataCon name is_infix {- Not infix -} + ; buildDataCon name is_infix stricts lbl_names univ_tyvars ex_tyvars eq_spec theta @@ -603,8 +617,8 @@ look at it. %************************************************************************ \begin{code} -tcIfaceInst :: IfaceInst -> IfL Instance -tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag, ifInstCls = cls, ifInstTys = mb_tcs }) = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ @@ -612,14 +626,12 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst -tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, - ifFamInstFam = fam, ifFamInstTys = mb_tcs }) --- { tycon' <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $ --- the above line doesn't work, but this below does => CPP in Haskell = evil! - = do tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ - tcIfaceTyCon tycon +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name } ) + = do axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ + tcIfaceCoAxiom axiom_name let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - return (mkImportedFamInst fam mb_tcs' tycon') + return (mkImportedFamInst fam mb_tcs' axiom') \end{code} @@ -733,9 +745,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse ; vScalarVars <- mapM vectVar scalarVars - ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2) + ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2) ; return $ VectInfo - { vectInfoVar = mkVarEnv vVars + { vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels , vectInfoTyCon = mkNameEnv vTyCons , vectInfoDataCon = mkNameEnv (concat vDataCons) , vectInfoScalarVars = mkVarSet vScalarVars @@ -753,6 +765,19 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo tcIfaceExtId vName ; return (var, (var, vVar)) } + -- where + -- lookupLocalOrExternalId name + -- = do { let mb_id = lookupTypeEnv typeEnv name + -- ; case mb_id of + -- -- id is local + -- Just (AnId id) -> return id + -- -- name is not an Id => internal inconsistency + -- Just _ -> notAnIdErr + -- -- Id is external + -- Nothing -> tcIfaceExtId name + -- } + -- + -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name) vectVar name = forkM (ptext (sLit "vect scalar var") <+> ppr name) $ @@ -767,13 +792,17 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo = vectTyConMapping vars name name vectTyConMapping vars name vName - = do { tycon <- lookupLocalOrExternal name - ; vTycon <- lookupLocalOrExternal vName + = do { tycon <- lookupLocalOrExternalTyCon name + ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ + lookupLocalOrExternalTyCon vName - -- map the data constructors of the original type constructor to those of the + -- Map the data constructors of the original type constructor to those of the -- vectorised type constructor /unless/ the type constructor was vectorised -- abstractly; if it was vectorised abstractly, the workers of its data constructors - -- do not appear in the set of vectorised variables + -- do not appear in the set of vectorised variables. + -- + -- NB: This is lazy! We don't pull at the type constructors before we actually use + -- the data constructor mapping. ; let isAbstract | isClassTyCon tycon = False | datacon:_ <- tyConDataCons tycon = not $ dataConWrapId datacon `elemVarSet` vars @@ -784,14 +813,25 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo (tyConDataCons vTycon) ] + -- Map the (implicit) superclass and methods selectors as they don't occur in + -- the var map. + vScSels | Just cls <- tyConClass_maybe tycon + , Just vCls <- tyConClass_maybe vTycon + = [ (sel, (sel, vSel)) + | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls) + ] + | otherwise + = [] + ; return ( (name, (tycon, vTycon)) -- (T, T_v) , vDataCons -- list of (Ci, Ci_v) + , vScSels -- list of (seli, seli_v) ) } where -- we need a fully defined version of the type constructor to be able to extract -- its data constructors etc. - lookupLocalOrExternal name + lookupLocalOrExternalTyCon name = do { let mb_tycon = lookupTypeEnv typeEnv name ; case mb_tycon of -- tycon is local diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index a9684a6a91..591419a251 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -1,10 +1,10 @@ \begin{code} module TcIface where -import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) +import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) import TypeRep ( TyThing ) import TcRnTypes ( IfL ) -import InstEnv ( Instance ) +import InstEnv ( ClsInst ) import FamInstEnv ( FamInst ) import CoreSyn ( CoreRule ) import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) @@ -14,7 +14,7 @@ import Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index aec492e151..32df9e3217 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -20,6 +20,9 @@ module Llvm ( LlvmBlocks, LlvmBlock(..), LlvmBlockId, LlvmParamAttr(..), LlvmParameter, + -- * Fence synchronization + LlvmSyncOrdering(..), + -- * Call Handling LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), LlvmLinkageType(..), LlvmFuncAttr(..), @@ -34,6 +37,9 @@ module Llvm ( -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + -- ** Metadata types + LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData, + -- ** Operations on the type system. isGlobal, getLitType, getLit, getName, getPlainName, getVarType, getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, @@ -42,7 +48,8 @@ module Llvm ( -- * Pretty Printing ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + llvmSDoc ) where diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 93bc62c91f..9133447331 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -31,6 +31,9 @@ data LlvmModule = LlvmModule { -- | LLVM Alias type definitions. modAliases :: [LlvmAlias], + -- | LLVM meta data. + modMeta :: [LlvmMeta], + -- | Global variables to include in the module. modGlobals :: [LMGlobal], @@ -59,8 +62,24 @@ data LlvmFunction = LlvmFunction { funcBody :: LlvmBlocks } -type LlvmFunctions = [LlvmFunction] - +type LlvmFunctions = [LlvmFunction] + +-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM +-- 3.0). Please see the LLVM documentation for a better description. +data LlvmSyncOrdering + -- | Some partial order of operations exists. + = SyncUnord + -- | A single total order for operations at a single address exists. + | SyncMonotonic + -- | Acquire synchronization operation. + | SyncAcquire + -- | Release synchronization operation. + | SyncRelease + -- | Acquire + Release synchronization operation. + | SyncAcqRel + -- | Full sequential Consistency operation. + | SyncSeqCst + deriving (Show, Eq) -- | Llvm Statements data LlvmStatement @@ -72,6 +91,11 @@ data LlvmStatement = Assignment LlvmVar LlvmExpression {- | + Memory fence operation + -} + | Fence Bool LlvmSyncOrdering + + {- | Always branch to the target label -} | Branch LlvmVar @@ -138,8 +162,15 @@ data LlvmStatement -} | Nop + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaData] LlvmStatement + deriving (Show, Eq) +type MetaData = (LMString, LlvmMetaUnamed) + -- | Llvm Expressions data LlvmExpression @@ -229,5 +260,10 @@ data LlvmExpression -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + {- | + A LLVM expression with metadata attached to it. + -} + | MetaExpr [MetaData] LlvmExpression + deriving (Show, Eq) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 217d02debf..c2177782f2 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -10,8 +10,10 @@ module Llvm.PpLlvm ( ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, - ppLlvmAlias, ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, @@ -38,15 +40,12 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments aliases globals decls funcs) - = ppLlvmComments comments - $+$ empty - $+$ ppLlvmAliases aliases - $+$ empty - $+$ ppLlvmGlobals globals - $+$ empty - $+$ ppLlvmFunctionDecls decls - $+$ empty +ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) + = ppLlvmComments comments $+$ newLine + $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas meta $+$ newLine + $+$ ppLlvmGlobals globals $+$ newLine + $+$ ppLlvmFunctionDecls decls $+$ newLine $+$ ppLlvmFunctions funcs -- | Print out a multi-line comment, can be inside a function or on its own @@ -80,6 +79,7 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = const' = if c then text "constant" else text "global" in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align + $+$ newLine ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth @@ -90,7 +90,33 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. ppLlvmAlias :: LlvmAlias -> Doc -ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty +ppLlvmAlias (name, ty) + = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: [LlvmMeta] -> Doc +ppLlvmMetas metas = vcat $ map ppLlvmMeta metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: LlvmMeta -> Doc +ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) + = exclamation <> int u <> text " = metadata !{" <> + hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" + +ppLlvmMeta (MetaNamed n metas) + = exclamation <> ftext n <> text " = !{" <> + hcat (intersperse comma $ map pprNode munq) <> text "}" + where + munq = map (\(LMMetaUnamed u) -> u) metas + pprNode n = exclamation <> int n + +-- | Print out an LLVM metadata value. +ppLlvmMetaVal :: LlvmMetaVal -> Doc +ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaVal (MetaVar v) = texts v +ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) + = text "metadata !" <> int u -- | Print out a list of function definitions. @@ -109,6 +135,8 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = $+$ lbrace $+$ ppLlvmBlocks body $+$ rbrace + $+$ newLine + $+$ newLine -- | Print out a function defenition header. ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc @@ -126,7 +154,6 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align - -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs @@ -146,7 +173,7 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) args = hcat $ intersperse (comma <> space) $ map (\(t,a) -> texts t <+> ppSpaceJoin a) p in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> - ftext n <> lparen <> args <> varg' <> rparen <> align + ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine -- | Print out a list of LLVM blocks. @@ -157,25 +184,45 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks -- It must be part of a function definition. ppLlvmBlock :: LlvmBlock -> Doc ppLlvmBlock (LlvmBlock blockId stmts) - = ppLlvmStatement (MkLabel blockId) - $+$ nest 4 (vcat $ map ppLlvmStatement stmts) + = go blockId stmts + where + lbreak acc [] = (Nothing, reverse acc, []) + lbreak acc (MkLabel id:xs) = (Just id, reverse acc, xs) + lbreak acc (x:xs) = lbreak (x:acc) xs + + go id code = + let (id2, block, rest) = lbreak [] code + ppRest = case id2 of + Just id2' -> go id2' rest + Nothing -> empty + in ppLlvmBlockLabel id + $+$ (vcat $ map ppLlvmStatement block) + $+$ newLine + $+$ ppRest + +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> Doc +ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon -- | Print out an LLVM statement. ppLlvmStatement :: LlvmStatement -> Doc -ppLlvmStatement stmt - = case stmt of - Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr) - Branch target -> ppBranch target - BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF - Comment comments -> ppLlvmComments comments - MkLabel label -> (llvmSDoc $ pprUnique label) <> colon - Store value ptr -> ppStore value ptr - Switch scrut def tgs -> ppSwitch scrut def tgs - Return result -> ppReturn result - Expr expr -> ppLlvmExpression expr - Unreachable -> text "unreachable" +ppLlvmStatement stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Fence st ord -> ind $ ppFence st ord + Branch target -> ind $ ppBranch target + BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments + MkLabel label -> ppLlvmBlockLabel label + Store value ptr -> ind $ ppStore value ptr + Switch scrut def tgs -> ind $ ppSwitch scrut def tgs + Return result -> ind $ ppReturn result + Expr expr -> ind $ ppLlvmExpression expr + Unreachable -> ind $ text "unreachable" Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s -- | Print out an LLVM expression. @@ -192,6 +239,7 @@ ppLlvmExpression expr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk + MetaExpr meta expr -> ppMetaExpr meta expr -------------------------------------------------------------------------------- @@ -254,6 +302,19 @@ ppCmpOp op left right = ppAssignment :: LlvmVar -> Doc -> Doc ppAssignment var expr = (text $ getName var) <+> equals <+> expr +ppFence :: Bool -> LlvmSyncOrdering -> Doc +ppFence st ord = + let singleThread = case st of True -> text "singlethread" + False -> empty + in text "fence" <+> singleThread <+> ppSyncOrdering ord + +ppSyncOrdering :: LlvmSyncOrdering -> Doc +ppSyncOrdering SyncUnord = text "unordered" +ppSyncOrdering SyncMonotonic = text "monotonic" +ppSyncOrdering SyncAcquire = text "acquire" +ppSyncOrdering SyncRelease = text "release" +ppSyncOrdering SyncAcqRel = text "acq_rel" +ppSyncOrdering SyncSeqCst = text "seq_cst" ppLoad :: LlvmVar -> Doc ppLoad var = text "load" <+> texts var @@ -327,6 +388,21 @@ ppAsm asm constraints rty vars sideeffect alignstack = <+> cons <> vars' +ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta + + +ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta + + +ppMetas :: [MetaData] -> Doc +ppMetas meta = hcat $ map ppMeta meta + where + ppMeta (name, (LMMetaUnamed n)) + = comma <+> exclamation <> ftext name <+> exclamation <> int n + + -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- @@ -344,3 +420,11 @@ llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d texts :: (Show a) => a -> Doc texts = (text . show) +-- | Blank line. +newLine :: Doc +newLine = text "" + +-- | Exclamation point. +exclamation :: Doc +exclamation = text "!" + diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 101342606d..35de40bdc4 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -7,6 +7,7 @@ module Llvm.Types where #include "HsVersions.h" import Data.Char +import Data.Int import Data.List (intercalate) import Numeric @@ -70,12 +71,49 @@ instance Show LlvmType where show (LMAlias (s,_)) = "%" ++ unpackFS s +-- | LLVM metadata values. Used for representing debug and optimization +-- information. +data LlvmMetaVal + -- | Metadata string + = MetaStr LMString + -- | Metadata node + | MetaNode LlvmMetaUnamed + -- | Normal value type as metadata + | MetaVar LlvmVar + deriving (Eq) + +-- | LLVM metadata nodes. +data LlvmMeta + -- | Unamed metadata + = MetaUnamed LlvmMetaUnamed [LlvmMetaVal] + -- | Named metadata + | MetaNamed LMString [LlvmMetaUnamed] + deriving (Eq) + +-- | Unamed metadata variable. +newtype LlvmMetaUnamed = LMMetaUnamed Int + +instance Eq LlvmMetaUnamed where + (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m + +instance Show LlvmMetaVal where + show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\"" + show (MetaNode n) = "metadata " ++ show n + show (MetaVar v) = show v + +instance Show LlvmMetaUnamed where + show (LMMetaUnamed u) = "!" ++ show u + +instance Show LlvmMeta where + show (MetaUnamed m _) = show m + show (MetaNamed m _) = "!" ++ unpackFS m + -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int type LMConst = Bool -- ^ is a variable constant or not --- | Llvm Variables +-- | LLVM Variables data LlvmVar -- | Variables with a global scope. = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst @@ -186,7 +224,9 @@ getPlainName (LMLitVar x ) = getLit x -- | Print a literal value. No type. getLit :: LlvmLit -> String -getLit (LMIntLit i _ ) = show ((fromInteger i)::Int) +getLit (LMIntLit i (LMInt 32)) = show (fromInteger i :: Int32) +getLit (LMIntLit i (LMInt 64)) = show (fromInteger i :: Int64) +getLit (LMIntLit i _ ) = show (fromInteger i :: Int) getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r getLit (LMFloatLit r LMDouble) = dToStr r getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index f802fc414c..531d90a8ee 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -27,6 +27,7 @@ import UniqSupply import Util import SysTools ( figureLlvmVersion ) +import Data.IORef ( writeIORef ) import Data.Maybe ( fromMaybe ) import System.IO @@ -37,7 +38,7 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () llvmCodeGen dflags h us cmms = let cmm = concat cmms (cdata,env) = {-# SCC "llvm_split" #-} - foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm + foldr split ([], initLlvmEnv dflags) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmProc i l _) (d,e) = let lbl = strCLabel_llvm env $ case i of @@ -47,9 +48,12 @@ llvmCodeGen dflags h us cmms in (d,env') in do showPass dflags "LlVM CodeGen" + dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + -- cache llvm version for later use + writeIORef (llvmVersion dflags) ver env' <- {-# SCC "llvm_datas_gen" #-} cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] {-# SCC "llvm_procs_gen" #-} diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index a896cdd482..9bdb115505 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,7 +13,7 @@ module LlvmCodeGen.Base ( LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, - ghcInternalFunctions, + getDflags, ghcInternalFunctions, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, @@ -32,6 +32,7 @@ import CLabel import CgUtils ( activeStgRegs ) import Config import Constants +import DynFlags import FastString import OldCmm import qualified Outputable as Outp @@ -150,12 +151,13 @@ defaultLlvmVersion = 28 -- -- two maps, one for functions and one for local vars. -newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, Platform) +newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags) + type LlvmEnvMap = UniqFM LlvmType -- | Get initial Llvm environment. -initLlvmEnv :: Platform -> LlvmEnv -initLlvmEnv platform = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, platform) +initLlvmEnv :: DynFlags -> LlvmEnv +initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ] -- | Here we pre-initialise some functions that are used internally by GHC @@ -211,7 +213,11 @@ setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p) -- | Get the platform we are generating code for getLlvmPlatform :: LlvmEnv -> Platform -getLlvmPlatform (LlvmEnv (_, _, _, p)) = p +getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d + +-- | Get the DynFlags for this compilation pass +getDflags :: LlvmEnv -> DynFlags +getDflags (LlvmEnv (_, _, _, d)) = d -- ---------------------------------------------------------------------------- -- * Label handling diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d8507ab810..059328f868 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -16,13 +16,14 @@ import CgUtils ( activeStgRegs, callerSaves ) import CLabel import OldCmm import qualified OldPprCmm as PprCmm -import OrdList +import DynFlags import FastString import ForeignCall import Outputable hiding ( panic, pprPanic ) import qualified Outputable import Platform +import OrdList import UniqSupply import Unique import Util @@ -127,25 +128,24 @@ stmtToInstrs env stmt = case stmt of -> genCall env target res args ret -- Tail call - CmmJump arg _ -> genJump env arg + CmmJump arg live -> genJump env arg live -- CPS, only tail calls, no return's -- Actually, there are a few return statements that occur because of hand -- written Cmm code. - CmmReturn _ + CmmReturn -> return (env, unitOL $ Return Nothing, []) --- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] - -> CmmReturnInfo -> UniqSM StmtData +-- | Memory barrier instruction for LLVM >= 3.0 +barrier :: LlvmEnv -> UniqSM StmtData +barrier env = do + let s = Fence False SyncSeqCst + return (env, unitOL s, []) --- Write barrier needs to be handled specially as it is implemented as an LLVM --- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier) _ _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | otherwise = do +-- | Memory barrier instruction for LLVM < 3.0 +oldBarrier :: LlvmEnv -> UniqSM StmtData +oldBarrier env = do let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign @@ -166,6 +166,18 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) +-- | Foreign Calls +genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] + -> CmmReturnInfo -> UniqSM StmtData + +-- Write barrier needs to be handled specially as it is implemented as an LLVM +-- intrinsic function. +genCall env (CmmPrim MO_WriteBarrier) _ _ _ + | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] + = return (env, nilOL, []) + | getLlvmVer env > 29 = barrier env + | otherwise = oldBarrier env + -- Handle popcnt function specifically since GHC only really has i32 and i64 -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM @@ -470,19 +482,19 @@ cmmPrimOpFunctions env mop -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData +genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData -- Call to known function -genJump env (CmmLit (CmmLabel lbl)) = do +genJump env (CmmLit (CmmLabel lbl)) live = do (env', vf, stmts, top) <- getHsFunc env lbl - (stgRegs, stgStmts) <- funEpilogue + (stgRegs, stgStmts) <- funEpilogue env live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) -- Call to unknown function / address -genJump env expr = do +genJump env expr live = do let fty = llvmFunTy (env', vf, stmts, top) <- exprToVar env expr @@ -494,7 +506,7 @@ genJump env expr = do ++ show (ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue + (stgRegs, stgStmts) <- funEpilogue env live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, @@ -550,7 +562,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [ = genStore_fast env addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val +genStore env addr val = genStore_slow env addr val [other] -- | CmmStore operation -- This is a special case for storing to a global register pointer @@ -558,8 +570,9 @@ genStore env addr val = genStore_slow env addr val genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -570,7 +583,7 @@ genStore_fast env addr r n val case pLower grt == getVarType vval of -- were fine True -> do - let s3 = Store vval ptr + let s3 = MetaStmt meta $ Store vval ptr return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -578,19 +591,19 @@ genStore_fast env addr r n val False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = Store vval ptr' + let s4 = MetaStmt meta $ Store vval ptr' return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val + False -> genStore_slow env addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData -genStore_slow env addr val = do +genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData +genStore_slow env addr val meta = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val @@ -599,17 +612,17 @@ genStore_slow env addr val = do -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vaddr + let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do - let s1 = Store vval vaddr + let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = Store vval vptr + let s2 = MetaStmt meta $ Store vval vptr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> @@ -841,8 +854,8 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1031,7 +1044,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [ = genLoad_fast env e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty +genLoad env e ty = genLoad_slow env e ty [other] -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer @@ -1039,9 +1052,10 @@ genLoad env e ty = genLoad_slow env e ty genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty + let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr + ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1051,7 +1065,7 @@ genLoad_fast env e r n ty = case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' $ Load ptr + (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) @@ -1059,29 +1073,31 @@ genLoad_fast env e r n ty = False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' $ Load ptr' + (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty + False -> genLoad_slow env e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData -genLoad_slow env e ty = do +genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData +genLoad_slow env e ty meta = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of LMPointer _ -> do - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load ptr) return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" @@ -1099,7 +1115,6 @@ genLoad_slow env e ty = do getCmmReg :: LlvmEnv -> CmmReg -> ExprData getCmmReg env r@(CmmLocal (LocalReg un _)) = let exists = varLookup un env - (newv, stmts) = allocReg r nenv = varInsert un (pLower $ getVarType newv) env in case exists of @@ -1197,15 +1212,33 @@ funPrologue = concat $ map getReg activeStgRegs -- | Function epilogue. Load STG variables to use as argument for call. -funEpilogue :: UniqSM ([LlvmVar], LlvmStatements) -funEpilogue = do - let loadExpr r = do - let reg = lmGlobalRegVar r +-- STG Liveness optimisation done here. +funEpilogue :: LlvmEnv -> Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements) + +-- Have information and liveness optimisation is enabled +funEpilogue env (Just live) | dopt Opt_RegLiveness (getDflags env) = do + loads <- mapM loadExpr activeStgRegs + let (vars, stmts) = unzip loads + return (vars, concatOL stmts) + where + loadExpr r | r `elem` alwaysLive || r `elem` live = do + let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) + loadExpr r = do + let ty = (pLower . getVarType $ lmGlobalRegVar r) + return (LMLitVar $ LMUndefLit ty, unitOL Nop) + +-- don't do liveness optimisation +funEpilogue _ _ = do loads <- mapM loadExpr activeStgRegs let (vars, stmts) = unzip loads return (vars, concatOL stmts) + where + loadExpr r = do + let reg = lmGlobalRegVar r + (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg + return (v, unitOL s) -- | A serries of statements to trash all the STG registers. diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index e0cebe5f21..187d1ecf03 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,6 +11,7 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data +import LlvmCodeGen.Regs import CLabel import OldCmm @@ -25,6 +26,16 @@ import Unique -- * Top level -- +-- | Header code for LLVM modules +pprLlvmHeader :: Doc +pprLlvmHeader = + moduleLayout + $+$ text "" + $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) + $+$ ppLlvmMetas stgTBAA + $+$ text "" + + -- | LLVM module layout description for the host target moduleLayout :: Doc moduleLayout = @@ -64,11 +75,6 @@ moduleLayout = #endif --- | Header code for LLVM modules -pprLlvmHeader :: Doc -pprLlvmHeader = - moduleLayout $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) - -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> Doc pprLlvmData (globals, types) = diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index b0c63a4c34..b7ff9f008e 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -3,7 +3,8 @@ -- module LlvmCodeGen.Regs ( - lmGlobalRegArg, lmGlobalRegVar + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA ) where #include "HsVersions.h" @@ -11,8 +12,8 @@ module LlvmCodeGen.Regs ( import Llvm import CmmExpr -import Outputable ( panic ) import FastString +import Outputable ( panic ) -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: GlobalReg -> LlvmVar @@ -24,7 +25,7 @@ lmGlobalRegArg = lmGlobalReg "_Arg" {- Need to make sure the names here can't conflict with the unique generated names. Uniques generated names containing only base62 chars. So using say - the '_' char guarantees this. + the '_' char guarantees this. -} lmGlobalReg :: String -> GlobalReg -> LlvmVar lmGlobalReg suf reg @@ -49,9 +50,60 @@ lmGlobalReg suf reg DoubleReg 2 -> doubleGlobal $ "D2" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg where wordGlobal name = LMNLocalVar (fsLit name) llvmWord ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr floatGlobal name = LMNLocalVar (fsLit name) LMFloat doubleGlobal name = LMNLocalVar (fsLit name) LMDouble +-- | A list of STG Registers that should always be considered alive +alwaysLive :: [GlobalReg] +alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] + +-- | STG Type Based Alias Analysis metadata +stgTBAA :: [LlvmMeta] +stgTBAA + = [ MetaUnamed topN [MetaStr (fsLit "top")] + , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN] + , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] + , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] + , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'. + -- OR I think the big thing is Sp is never aliased, so might want + -- to change the hieracy to have Sp on its own branch that is never + -- aliased (e.g never use top as a TBAA node). + , MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN] + ] + +-- | Id values +topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed +topN = LMMetaUnamed 0 +stackN = LMMetaUnamed 1 +heapN = LMMetaUnamed 2 +rxN = LMMetaUnamed 3 +baseN = LMMetaUnamed 4 +otherN = LMMetaUnamed 5 + +-- | The various TBAA types +top, heap, stack, rx, base, other :: MetaData +top = (tbaa, topN) +heap = (tbaa, heapN) +stack = (tbaa, stackN) +rx = (tbaa, rxN) +base = (tbaa, baseN) +other = (tbaa, otherN) + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> MetaData +getTBAA BaseReg = base +getTBAA Sp = stack +getTBAA Hp = heap +getTBAA (VanillaReg _ _) = rx +getTBAA _ = top + diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index c0301dc29b..148e11f65b 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -80,8 +80,7 @@ addErr :: Monad m => String -> EwM m () addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ())) - where w = "Warning: " ++ msg +addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ())) deprecate :: Monad m => String -> EwM m () deprecate s = do diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 0623641c41..f29b479db2 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -4,13 +4,6 @@ \section{Code output phase} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" @@ -18,9 +11,9 @@ module CodeOutput( codeOutput, outputForeignStubs ) where import AsmCodeGen ( nativeCodeGen ) import LlvmCodeGen ( llvmCodeGen ) -import UniqSupply ( mkSplitUniqSupply ) +import UniqSupply ( mkSplitUniqSupply ) -import Finder ( mkStubPaths ) +import Finder ( mkStubPaths ) import PprC ( writeCs ) import OldCmmLint ( cmmLint ) import Packages @@ -33,10 +26,10 @@ import SysTools import Stream (Stream) import qualified Stream -import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) +import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Module -import Maybes ( firstJusts ) +import Maybes ( firstJusts ) import Control.Exception import Control.Monad @@ -46,14 +39,14 @@ import System.IO \end{code} %************************************************************************ -%* * +%* * \subsection{Steering} -%* * +%* * %************************************************************************ \begin{code} codeOutput :: DynFlags - -> Module + -> Module -> ModLocation -> ForeignStubs -> [PackageId] @@ -88,9 +81,9 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream HscC -> outputC dflags filenm linted_cmm_stream pkg_deps; HscLlvm -> outputLlvm dflags filenm linted_cmm_stream; HscNothing -> panic "codeOutput: HscNothing" - } - ; return stubs_exist - } + } + ; return stubs_exist + } doOutput :: String -> (Handle -> IO ()) -> IO () doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action @@ -98,9 +91,9 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action %************************************************************************ -%* * +%* * \subsection{C} -%* * +%* * %************************************************************************ \begin{code} @@ -125,26 +118,26 @@ outputC dflags filenm cmm_stream packages let rts = getPackageDetails (pkgState dflags) rtsPackageId let cc_injects = unlines (map mk_include (includes rts)) - mk_include h_file = - case h_file of - '"':_{-"-} -> "#include "++h_file - '<':_ -> "#include "++h_file - _ -> "#include \""++h_file++"\"" + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" pkg_configs <- getPreloadPackagesAnd dflags packages let pkg_names = map (display.sourcePackageId) pkg_configs doOutput filenm $ \ h -> do - hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects writeCs dflags h rawcmms \end{code} %************************************************************************ -%* * +%* * \subsection{Assembler} -%* * +%* * %************************************************************************ \begin{code} @@ -163,9 +156,9 @@ outputAsm dflags filenm cmm_stream %************************************************************************ -%* * +%* * \subsection{LLVM} -%* * +%* * %************************************************************************ \begin{code} @@ -184,14 +177,14 @@ outputLlvm dflags filenm cmm_stream %************************************************************************ -%* * +%* * \subsection{Foreign import/export} -%* * +%* * %************************************************************************ \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs - -> IO (Bool, -- Header file created + -> IO (Bool, -- Header file created Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs = do @@ -200,54 +193,54 @@ outputForeignStubs dflags mod location stubs case stubs of NoStubs -> do - -- When compiling External Core files, may need to use stub - -- files from a previous compilation + -- When compiling External Core files, may need to use stub + -- files from a previous compilation stub_h_exists <- doesFileExist stub_h return (stub_h_exists, Nothing) ForeignStubs h_code c_code -> do let - stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc stub_c_output_d - - -- Header file protos for "foreign export"ed functions. - stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc stub_h_output_d - -- in + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode CStyle h_code + stub_h_output_w = showSDoc stub_h_output_d + -- in createDirectoryHierarchy (takeDirectory stub_h) - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d - -- we need the #includes from the rts package for the stub files - let rts_includes = - let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in - concatMap mk_include (includes rts_pkg) - mk_include i = "#include \"" ++ i ++ "\"\n" + -- we need the #includes from the rts package for the stub files + let rts_includes = + let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in + concatMap mk_include (includes rts_pkg) + mk_include i = "#include \"" ++ i ++ "\"\n" -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes | cLibFFI = "#include \"ffi.h\"\n" | otherwise = "" - stub_h_file_exists + stub_h_file_exists <- outputForeignStubs_help stub_h stub_h_output_w - ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr + ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export stubs" stub_c_output_d - stub_c_file_exists + stub_c_file_exists <- outputForeignStubs_help stub_c stub_c_output_w - ("#define IN_STG_CODE 0\n" ++ - "#include \"Rts.h\"\n" ++ - rts_includes ++ - ffi_includes ++ - cplusplus_hdr) - cplusplus_ftr - -- We're adding the default hc_header to the stub file, but this - -- isn't really HC code, so we need to define IN_STG_CODE==0 to - -- avoid the register variables etc. being enabled. + ("#define IN_STG_CODE 0\n" ++ + "#include \"Rts.h\"\n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. return (stub_h_file_exists, if stub_c_file_exists then Just stub_c diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 2230f3fa40..df6e7fd163 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -137,10 +137,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- We add the directory in which the .hs files resides) to the import path. -- This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. - let current_dir = case takeDirectory basename of - "" -> "." -- XXX Hack required for filepath-1.1 and earlier - -- (GHC 6.12 and earlier) - d -> d + let current_dir = takeDirectory basename old_paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : old_paths } hsc_env = hsc_env0 {hsc_dflags = dflags} @@ -193,7 +190,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) (Just location) maybe_stub_o -- The object filename comes from the ModLocation - o_time <- getModificationTime object_filename + o_time <- getModificationUTCTime object_filename return ([DotO object_filename], o_time) let linkable = LM unlinked_time this_mod hs_unlinked @@ -356,13 +353,13 @@ linkingNeeded dflags linkables pkg_deps = do -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). let exe_file = exeFileName dflags - e_exe_time <- tryIO $ getModificationTime exe_file + e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs extra_ld_inputs <- readIORef v_Ld_inputs - e_extra_times <- mapM (tryIO . getModificationTime) extra_ld_inputs + e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times @@ -378,7 +375,7 @@ linkingNeeded dflags linkables pkg_deps = do pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (tryIO . getModificationTime) + e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) let (lib_errs,lib_times) = splitEithers e_lib_times if not (null lib_errs) || any (t <) lib_times @@ -598,8 +595,8 @@ getPipeEnv = P $ \env state -> return (state, env) getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state) -getDynFlags :: CompPipeline DynFlags -getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> @@ -849,11 +846,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is -- what gcc does, and it's probably what you want. - let current_dir = case takeDirectory basename of - "" -> "." -- XXX Hack required for filepath-1.1 and earlier - -- (GHC 6.12 and earlier) - d -> d - + let current_dir = takeDirectory basename paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } @@ -913,7 +906,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- io $ getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationUTCTime (basename <.> suff) let hsc_lang = hscTarget dflags source_unchanged <- io $ @@ -926,7 +919,7 @@ runPhase (Hsc src_flavour) input_fn dflags0 else do o_file_exists <- doesFileExist o_file if not o_file_exists then return SourceModified -- Need to recompile - else do t2 <- getModificationTime o_file + else do t2 <- getModificationUTCTime o_file if t2 > src_timestamp then return SourceUnmodified else return SourceModified @@ -1313,15 +1306,21 @@ runPhase SplitAs _input_fn dflags runPhase LlvmOpt input_fn dflags = do - let lo_opts = getOpts dflags opt_lo - let opt_lvl = max 0 (min 2 $ optLevel dflags) - -- don't specify anything if user has specified commands. We do this for - -- opt but not llc since opt is very specifically for optimisation passes - -- only, so if the user is passing us extra options we assume they know - -- what they are doing and don't get in the way. - let optFlag = if null lo_opts - then [SysTools.Option (llvmOpts !! opt_lvl)] - else [] + ver <- io $ readIORef (llvmVersion dflags) + + let lo_opts = getOpts dflags opt_lo + opt_lvl = max 0 (min 2 $ optLevel dflags) + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null lo_opts + then [SysTools.Option (llvmOpts !! opt_lvl)] + else [] + tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier + | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + | otherwise = "--enable-tbaa=false" + output_fn <- phaseOutputFilename LlvmLlc @@ -1330,6 +1329,7 @@ runPhase LlvmOpt input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag + ++ [SysTools.Option tbaa] ++ map SysTools.Option lo_opts) return (LlvmLlc, output_fn) @@ -1343,11 +1343,16 @@ runPhase LlvmOpt input_fn dflags runPhase LlvmLlc input_fn dflags = do + ver <- io $ readIORef (llvmVersion dflags) + let lc_opts = getOpts dflags opt_lc opt_lvl = max 0 (min 2 $ optLevel dflags) rmodel | opt_PIC = "pic" | not opt_Static = "dynamic-no-pic" | otherwise = "static" + tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier + | dopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + | otherwise = "--enable-tbaa=false" -- hidden debugging flag '-dno-llvm-mangler' to skip mangling let next_phase = case dopt Opt_NoLlvmMangler dflags of @@ -1363,6 +1368,7 @@ runPhase LlvmLlc input_fn dflags SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts + ++ [SysTools.Option tbaa] ++ map SysTools.Option fpOpts) return (next_phase, output_fn) @@ -1380,7 +1386,7 @@ runPhase LlvmLlc input_fn dflags else if (elem VFPv3D16 ext) then ["-mattr=+v7,+vfp3,+d16"] else [] - _ -> [] + _ -> [] ----------------------------------------------------------------------------- -- LlvmMangle phase diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index f52ff930e2..0553bd8848 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -29,6 +29,7 @@ module DynFlags ( xopt_set, xopt_unset, DynFlags(..), + HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, GhcMode(..), isOneShot, @@ -112,7 +113,7 @@ import Outputable #ifdef GHCI import Foreign.C ( CInt(..) ) #endif -import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) #ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) @@ -249,6 +250,8 @@ data DynFlag | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA + | Opt_RegLiveness -- Use the STG Reg liveness information -- Interface files | Opt_IgnoreInterfacePragmas @@ -287,6 +290,7 @@ data DynFlag | Opt_GhciSandbox | Opt_GhciHistory | Opt_HelpfulErrors + | Opt_DeferTypeErrors -- temporary flags | Opt_RunCPS @@ -344,6 +348,7 @@ data WarningFlag = | Opt_WarnAlternativeLayoutRuleTransitional | Opt_WarnUnsafe | Opt_WarnSafe + | Opt_WarnPointlessPragmas deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -402,6 +407,7 @@ data ExtensionFlag | Opt_RebindableSyntax | Opt_ConstraintKinds | Opt_PolyKinds -- Kind polymorphism + | Opt_DataKinds -- Datatype promotion | Opt_InstanceSigs | Opt_StandaloneDeriving @@ -563,11 +569,12 @@ data DynFlags = DynFlags { language :: Maybe Language, -- | Safe Haskell mode safeHaskell :: SafeHaskellMode, - -- We store the location of where template haskell and newtype deriving were - -- turned on so we can produce accurate error messages when Safe Haskell turns - -- them off. + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. thOnLoc :: SrcSpan, newDerivOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, -- Don't change this without updating extensionFlags: @@ -576,15 +583,23 @@ data DynFlags = DynFlags { -- flattenExtensionFlags language extensions extensionFlags :: IntSet, - -- | Message output action: use "ErrUtils" instead of this if you can + -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, haddockOptions :: Maybe String, -- | what kind of {-# SCC #-} to add automatically - profAuto :: ProfAuto + profAuto :: ProfAuto, + + llvmVersion :: IORef (Int) } +class HasDynFlags m where + getDynFlags :: m DynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + data ProfAuto = NoProfAuto -- ^ no SCC annotations added | ProfAutoAll -- ^ top-level and nested functions are annotated @@ -815,13 +830,15 @@ initDynFlags dflags = do refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refGeneratedDumps <- newIORef Set.empty + refLlvmVersion <- newIORef 28 return dflags{ - ways = ways, - buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), - rtsBuildTag = mkBuildTag ways, - filesToClean = refFilesToClean, - dirsToClean = refDirsToClean, - generatedDumps = refGeneratedDumps + ways = ways, + buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), + rtsBuildTag = mkBuildTag ways, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps, + llvmVersion = refLlvmVersion } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -907,15 +924,17 @@ defaultDynFlags mySettings = safeHaskell = Sf_SafeInfered, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction, - profAuto = NoProfAuto + profAuto = NoProfAuto, + llvmVersion = panic "defaultDynFlags: No llvmVersion" } -type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO () +type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () defaultLogAction :: LogAction defaultLogAction severity srcSpan style msg @@ -924,7 +943,7 @@ defaultLogAction severity srcSpan style msg SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage srcSpan msg) style + printErrs (mkLocMessage severity srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, whereas -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. @@ -1302,19 +1321,28 @@ parseDynamicFlags dflags0 args cmdline = do when (not (null errs)) $ ghcError $ errorsToGhcException errs -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck dflags1 + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 return (dflags2, leftover, sh_warns ++ warns) -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -safeFlagCheck :: DynFlags -> (DynFlags, [Located String]) -safeFlagCheck dflags | not (safeLanguageOn dflags || safeInferOn dflags) - = (dflags, []) -safeFlagCheck dflags = +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) + = (dflags, []) + +safeFlagCheck cmdl dflags = case safeLanguageOn dflags of True -> (dflags', warns) + -- throw error if -fpackage-trust by itself with no safe haskell flag + False | not cmdl && safeInferOn dflags && packageTrustOn dflags + -> (dopt_unset dflags' Opt_PackageTrust, + [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + ) + False | null warns && safeInfOk -> (dflags', []) @@ -1334,8 +1362,8 @@ safeFlagCheck dflags = apFix f = if safeInferOn dflags then id else f - safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in" - ++ " Safe Haskell; ignoring " ++ str] + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, xopt Opt_GeneralizedNewtypeDeriving, @@ -1660,7 +1688,7 @@ dynamic_flags = [ , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) ------ Safe Haskell flags ------------------------------------------- - , Flag "fpackage-trust" (NoArg (setDynFlag Opt_PackageTrust)) + , Flag "fpackage-trust" (NoArg setPackageTrust) , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None)) ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags @@ -1689,9 +1717,9 @@ package_flags = [ , Flag "ignore-package" (HasArg ignorePackage) , Flag "syslib" (HasArg (\s -> do exposePackage s deprecate "Use -package instead")) + , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) , Flag "trust" (HasArg trustPackage) , Flag "distrust" (HasArg distrustPackage) - , Flag "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on @@ -1766,7 +1794,8 @@ fWarningFlags = [ ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), ( "warn-unsafe", Opt_WarnUnsafe, setWarnUnsafe ), - ( "warn-safe", Opt_WarnSafe, setWarnSafe ) ] + ( "warn-safe", Opt_WarnSafe, setWarnSafe ), + ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] @@ -1807,6 +1836,8 @@ fFlags = [ ( "vectorise", Opt_Vectorise, nop ), ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), + ( "llvm-tbaa", Opt_LlvmTBAA, nop), + ( "reg-liveness", Opt_RegLiveness, nop), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), @@ -1814,6 +1845,7 @@ fFlags = [ ( "ghci-sandbox", Opt_GhciSandbox, nop ), ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), + ( "defer-type-errors", Opt_DeferTypeErrors, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), @@ -1935,6 +1967,7 @@ xFlags = [ ( "RebindableSyntax", Opt_RebindableSyntax, nop ), ( "ConstraintKinds", Opt_ConstraintKinds, nop ), ( "PolyKinds", Opt_PolyKinds, nop ), + ( "DataKinds", Opt_DataKinds, nop ), ( "InstanceSigs", Opt_InstanceSigs, nop ), ( "MonoPatBinds", Opt_MonoPatBinds, \ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ), @@ -2022,8 +2055,6 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures -- all over the place - , (Opt_PolyKinds, turnOn, Opt_KindSignatures) - , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) -- Record wild-cards implies field disambiguation @@ -2054,6 +2085,8 @@ optLevelFlags , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) , ([2], Opt_RegsGraph) + , ([0,1,2], Opt_LlvmTBAA) + , ([0,1,2], Opt_RegLiveness) -- , ([2], Opt_StaticArgumentTransformation) -- Max writes: I think it's probably best not to enable SAT with -O2 for the @@ -2087,7 +2120,8 @@ standardWarnings Opt_WarnLazyUnliftedBindings, Opt_WarnDodgyForeignImports, Opt_WarnWrongDoBind, - Opt_WarnAlternativeLayoutRuleTransitional + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnPointlessPragmas ] minusWOpts :: [WarningFlag] @@ -2173,6 +2207,12 @@ setWarnUnsafe :: Bool -> DynP () setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) setWarnUnsafe False = return () +setPackageTrust :: DynP () +setPackageTrust = do + setDynFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + setGenDeriving :: Bool -> DynP () setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) setGenDeriving False = return () diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 1cce4ec633..6ba9df436c 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -6,15 +6,15 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, - Severity(..), - - ErrMsg, WarnMsg, - ErrorMessages, WarningMessages, + ErrMsg, WarnMsg, Severity(..), + Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - Messages, errorsFound, emptyMessages, + MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + pprLocErrMsg, makeIntoWarning, + + errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printBagOfErrors, printBagOfWarnings, + printBagOfErrors, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -36,6 +36,7 @@ module ErrUtils ( import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import Util import Outputable +import FastString import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) @@ -51,10 +52,21 @@ import System.IO -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. -type Message = SDoc +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg -pprMessageBag :: Bag Message -> SDoc -pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) +data ErrMsg = ErrMsg { + errMsgSpans :: [SrcSpan], + errMsgContext :: PrintUnqualified, + errMsgShortDoc :: MsgDoc, + errMsgExtraInfo :: MsgDoc, + errMsgSeverity :: Severity + } + -- The SrcSpan is used for sorting errors into line-number order + +type WarnMsg = ErrMsg +type MsgDoc = SDoc data Severity = SevOutput @@ -63,70 +75,56 @@ data Severity | SevError | SevFatal -mkLocMessage :: SrcSpan -> Message -> Message -mkLocMessage locn msg - | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg - | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg - -- always print the location, even if it is unhelpful. Error messages +instance Show ErrMsg where + show em = showSDoc (errMsgShortDoc em) + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". +mkLocMessage severity locn msg + | opt_ErrorSpans = hang (ppr locn <> colon <+> sev_info) 4 msg + | otherwise = hang (ppr (srcSpanStart locn) <> colon <+> sev_info) 4 msg + where + sev_info = case severity of + SevWarning -> ptext (sLit "Warning:") + _other -> empty + -- For warnings, print Foo.hs:34: Warning: + -- <the warning message> -printError :: SrcSpan -> Message -> IO () -printError span msg = - printErrs (mkLocMessage span msg) defaultErrStyle +printError :: SrcSpan -> MsgDoc -> IO () +printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle +makeIntoWarning :: ErrMsg -> ErrMsg +makeIntoWarning err = err { errMsgSeverity = SevWarning } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -data ErrMsg = ErrMsg { - errMsgSpans :: [SrcSpan], - errMsgContext :: PrintUnqualified, - errMsgShortDoc :: Message, - errMsgExtraInfo :: Message - } - -- The SrcSpan is used for sorting errors into line-number order - -instance Show ErrMsg where - show em = showSDoc (errMsgShortDoc em) - -type WarnMsg = ErrMsg - --- A short (one-line) error message, with context to tell us whether --- to qualify names in the message or not. -mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg -mkErrMsg locn print_unqual msg - = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = empty } - --- Variant that doesn't care about qualified/unqualified names -mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg -mkPlainErrMsg locn msg - = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify - , errMsgShortDoc = msg, errMsgExtraInfo = empty } - --- A long (multi-line) error message, with context to tell us whether --- to qualify names in the message or not. -mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg -mkLongErrMsg locn print_unqual msg extra +mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = extra } - -mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg -mkWarnMsg = mkErrMsg - -mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg -mkLongWarnMsg = mkLongErrMsg - + , errMsgShortDoc = msg, errMsgExtraInfo = extra + , errMsgSeverity = sev } + +mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- A long (multi-line) error message +mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg -- Variant that doesn't care about qualified/unqualified names -mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg -mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg -type Messages = (Bag WarnMsg, Bag ErrMsg) - -type WarningMessages = Bag WarnMsg -type ErrorMessages = Bag ErrMsg +mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra +mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty +mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty +mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra +mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty +mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty +---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) @@ -137,12 +135,8 @@ errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors = - printMsgBag dflags bag_of_errors SevError - -printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO () -printBagOfWarnings dflags bag_of_warns = - printMsgBag dflags bag_of_warns SevWarning +printBagOfErrors dflags bag_of_errors + = printMsgBag dflags bag_of_errors pprErrMsgBag :: Bag ErrMsg -> [SDoc] pprErrMsgBag bag @@ -152,12 +146,23 @@ pprErrMsgBag bag errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] -printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () -printMsgBag dflags bag sev +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpans = spans + , errMsgShortDoc = d + , errMsgExtraInfo = e + , errMsgSeverity = sev + , errMsgContext = unqual }) + = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e)) + where + (s : _) = spans -- Should be non-empty + +printMsgBag :: DynFlags -> Bag ErrMsg -> IO () +printMsgBag dflags bag = sequence_ [ let style = mkErrStyle unqual in log_action dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, + errMsgSeverity = sev, errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] @@ -293,22 +298,22 @@ ifVerbose dflags val act | verbosity dflags >= val = act | otherwise = return () -putMsg :: DynFlags -> Message -> IO () +putMsg :: DynFlags -> MsgDoc -> IO () putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg -putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO () +putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () putMsgWith dflags print_unqual msg = log_action dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay -errorMsg :: DynFlags -> Message -> IO () +errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg -fatalErrorMsg :: DynFlags -> Message -> IO () +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg -fatalErrorMsg' :: LogAction -> Message -> IO () +fatalErrorMsg' :: LogAction -> MsgDoc -> IO () fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () @@ -319,7 +324,7 @@ showPass :: DynFlags -> String -> IO () showPass dflags what = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) -debugTraceMsg :: DynFlags -> Int -> Message -> IO () +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) \end{code} diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 08115a4b48..7718cbe2a6 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -11,8 +11,8 @@ data Severity | SevError | SevFatal -type Message = SDoc +type MsgDoc = SDoc -mkLocMessage :: SrcSpan -> Message -> Message +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc \end{code} diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 3ac3a473a3..1417dad061 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -46,8 +46,8 @@ import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import System.Time ( ClockTime ) import Data.List ( partition ) +import Data.Time type FileExt = String -- Filename extension @@ -528,7 +528,7 @@ findObjectLinkableMaybe mod locn -- Make an object linkable when we know the object file exists, and we know -- its modification time. -findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) -- We used to look for _stub.o files here, but that was a bug (#706) -- Now GHC merges the stub.o into the main .o (#3687) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9665c60f2f..d3a8bb11de 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -6,17 +6,10 @@ -- -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module GHC ( - -- * Initialisation - defaultErrorHandler, - defaultCleanupHandler, + -- * Initialisation + defaultErrorHandler, + defaultCleanupHandler, -- * GHC Monad Ghc, GhcT, GhcMonad(..), HscEnv, @@ -27,31 +20,31 @@ module GHC ( handleSourceError, needsTemplateHaskell, - -- * Flags and settings - DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, + -- * Flags and settings + DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, GhcMode(..), GhcLink(..), defaultObjectTarget, - parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, - parseStaticFlags, - - -- * Targets - Target(..), TargetId(..), Phase, - setTargets, - getTargets, - addTarget, - removeTarget, - guessTarget, - - -- * Loading\/compiling the program - depanal, + parseDynamicFlags, + getSessionDynFlags, + setSessionDynFlags, + parseStaticFlags, + + -- * Targets + Target(..), TargetId(..), Phase, + setTargets, + getTargets, + addTarget, + removeTarget, + guessTarget, + + -- * Loading\/compiling the program + depanal, load, LoadHowMuch(..), InteractiveImport(..), - SuccessFlag(..), succeeded, failed, + SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, - workingDirectoryChanged, + workingDirectoryChanged, parseModule, typecheckModule, desugarModule, loadModule, ParsedModule(..), TypecheckedModule(..), DesugaredModule(..), - TypecheckedSource, ParsedSource, RenamedSource, -- ditto + TypecheckedSource, ParsedSource, RenamedSource, -- ditto TypecheckedMod, ParsedMod, moduleInfo, renamedSource, typecheckedSource, parsedSource, coreModule, @@ -61,50 +54,50 @@ module GHC ( compileToCoreModule, compileToCoreSimplified, compileCoreToObj, - -- * Inspecting the module structure of the program - ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), + -- * Inspecting the module structure of the program + ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModSummary, getModuleGraph, - isLoaded, - topSortModuleGraph, - - -- * Inspecting modules - ModuleInfo, - getModuleInfo, - modInfoTyThings, - modInfoTopLevelScope, + isLoaded, + topSortModuleGraph, + + -- * Inspecting modules + ModuleInfo, + getModuleInfo, + modInfoTyThings, + modInfoTopLevelScope, modInfoExports, - modInfoInstances, - modInfoIsExportedName, - modInfoLookupName, + modInfoInstances, + modInfoIsExportedName, + modInfoLookupName, modInfoIface, - lookupGlobalName, - findGlobalAnns, + lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), -- * Querying the environment packageDbModules, - -- * Printing - PrintUnqualified, alwaysQualify, + -- * Printing + PrintUnqualified, alwaysQualify, - -- * Interactive evaluation - getBindings, getInsts, getPrintUnqual, - findModule, - lookupModule, + -- * Interactive evaluation + getBindings, getInsts, getPrintUnqual, + findModule, lookupModule, #ifdef GHCI - setContext, getContext, - getNamesInScope, - getRdrNamesInScope, + isModuleTrusted, + setContext, getContext, + getNamesInScope, + getRdrNamesInScope, getGRE, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - RunResult(..), - runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + RunResult(..), + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, @@ -115,9 +108,9 @@ module GHC ( abandon, abandonAll, InteractiveEval.back, InteractiveEval.forward, - showModule, + showModule, isModuleInterpreted, - InteractiveEval.compileExpr, HValue, dynCompileExpr, + InteractiveEval.compileExpr, HValue, dynCompileExpr, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, @@ -126,106 +119,106 @@ module GHC ( #endif lookupName, - -- * Abstract syntax elements + -- * Abstract syntax elements -- ** Packages PackageId, - -- ** Modules - Module, mkModule, pprModule, moduleName, modulePackageId, + -- ** Modules + Module, mkModule, pprModule, moduleName, modulePackageId, ModuleName, mkModuleName, moduleNameString, - -- ** Names - Name, - isExternalName, nameModule, pprParenSymName, nameSrcSpan, - NamedThing(..), - RdrName(Qual,Unqual), - - -- ** Identifiers - Id, idType, - isImplicitId, isDeadBinder, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, - isPrimOpId, isFCallId, isClassOpId_maybe, - isDataConWorkId, idDataCon, - isBottomingId, isDictonaryId, - recordSelectorFieldLabel, - - -- ** Type constructors - TyCon, - tyConTyVars, tyConDataCons, tyConArity, - isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isFamilyTyCon, tyConClass_maybe, - synTyConDefn, synTyConType, synTyConResKind, - - -- ** Type variables - TyVar, - alphaTyVars, - - -- ** Data constructors - DataCon, - dataConSig, dataConType, dataConTyCon, dataConFieldLabels, - dataConIsInfix, isVanillaDataCon, dataConUserType, - dataConStrictMarks, - StrictnessMark(..), isMarkedStrict, - - -- ** Classes - Class, - classMethods, classSCTheta, classTvsFds, classATs, - pprFundeps, - - -- ** Instances - Instance, - instanceDFunId, + -- ** Names + Name, + isExternalName, nameModule, pprParenSymName, nameSrcSpan, + NamedThing(..), + RdrName(Qual,Unqual), + + -- ** Identifiers + Id, idType, + isImplicitId, isDeadBinder, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isFCallId, isClassOpId_maybe, + isDataConWorkId, idDataCon, + isBottomingId, isDictonaryId, + recordSelectorFieldLabel, + + -- ** Type constructors + TyCon, + tyConTyVars, tyConDataCons, tyConArity, + isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, + isFamilyTyCon, tyConClass_maybe, + synTyConDefn, synTyConType, synTyConResKind, + + -- ** Type variables + TyVar, + alphaTyVars, + + -- ** Data constructors + DataCon, + dataConSig, dataConType, dataConTyCon, dataConFieldLabels, + dataConIsInfix, isVanillaDataCon, dataConUserType, + dataConStrictMarks, + StrictnessMark(..), isMarkedStrict, + + -- ** Classes + Class, + classMethods, classSCTheta, classTvsFds, classATs, + pprFundeps, + + -- ** Instances + ClsInst, + instanceDFunId, pprInstance, pprInstanceHdr, pprFamInst, pprFamInstHdr, - -- ** Types and Kinds - Type, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, - Kind, - PredType, - ThetaType, pprForAll, pprThetaArrowTy, + -- ** Types and Kinds + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, + Kind, + PredType, + ThetaType, pprForAll, pprThetaArrowTy, - -- ** Entities - TyThing(..), + -- ** Entities + TyThing(..), - -- ** Syntax - module HsSyn, -- ToDo: remove extraneous bits + -- ** Syntax + module HsSyn, -- ToDo: remove extraneous bits - -- ** Fixities - FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, - compareFixity, + -- ** Fixities + FixityDirection(..), + defaultFixity, maxPrecedence, + negateFixity, + compareFixity, - -- ** Source locations - SrcLoc(..), RealSrcLoc, + -- ** Source locations + SrcLoc(..), RealSrcLoc, mkSrcLoc, noSrcLoc, - srcLocFile, srcLocLine, srcLocCol, + srcLocFile, srcLocLine, srcLocCol, SrcSpan(..), RealSrcSpan, mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, - srcSpanFile, + srcSpanFile, srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, -- ** Located - GenLocated(..), Located, + GenLocated(..), Located, - -- *** Constructing Located - noLoc, mkGeneralLocated, + -- *** Constructing Located + noLoc, mkGeneralLocated, - -- *** Deconstructing Located - getLoc, unLoc, + -- *** Deconstructing Located + getLoc, unLoc, - -- *** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, + -- *** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf, - -- * Exceptions - GhcException(..), showGhcException, + -- * Exceptions + GhcException(..), showGhcException, -- * Token stream manipulations Token, @@ -235,9 +228,9 @@ module GHC ( -- * Pure interface to the parser parser, - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, + -- * Miscellaneous + --sessionHscEnv, + cyclicModuleErr, ) where {- @@ -258,7 +251,7 @@ import InteractiveEval import HscMain import GhcMake -import DriverPipeline ( compile' ) +import DriverPipeline ( compile' ) import GhcMonad import TcRnTypes import Packages @@ -267,10 +260,10 @@ import RdrName import qualified HsSyn -- hack as we want to reexport the whole module import HsSyn import Type hiding( typeKind ) -import Kind ( synTyConResKind ) -import TcType hiding( typeKind ) +import Kind ( synTyConResKind ) +import TcType hiding( typeKind ) import Id -import TysPrim ( alphaTyVars ) +import TysPrim ( alphaTyVars ) import TyCon import Class import DataCon @@ -292,26 +285,26 @@ import Annotations import Module import UniqFM import Panic -import Bag ( unitBag ) +import Bag ( unitBag ) import ErrUtils import MonadUtils import Util import StringBuffer import Outputable import BasicTypes -import Maybes ( expectJust ) +import Maybes ( expectJust ) import FastString import qualified Parser import Lexer import System.Directory ( doesFileExist, getCurrentDirectory ) import Data.Maybe -import Data.List ( find ) +import Data.List ( find ) +import Data.Time import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import Control.Monad -import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( getClockTime ) +import System.Exit ( exitWith, ExitCode(..) ) import Exception import Data.IORef import System.FilePath @@ -320,9 +313,9 @@ import Prelude hiding (init) -- %************************************************************************ --- %* * +-- %* * -- Initialisation: exception handlers --- %* * +-- %* * -- %************************************************************************ @@ -340,7 +333,7 @@ defaultErrorHandler la inner = Just (ioe :: IOException) -> fatalErrorMsg' la (text (show ioe)) _ -> case fromException exception of - Just UserInterrupt -> exitWith (ExitFailure 1) + Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") _ -> case fromException exception of @@ -354,13 +347,13 @@ defaultErrorHandler la inner = -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do - hFlush stdout - case ge of - PhaseFailed _ code -> exitWith code - Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg' la (text (show ge)) - exitWith (ExitFailure 1) - ) $ + hFlush stdout + case ge of + PhaseFailed _ code -> exitWith code + Signal _ -> exitWith (ExitFailure 1) + _ -> do fatalErrorMsg' la (text (show ge)) + exitWith (ExitFailure 1) + ) $ inner -- | Install a default cleanup handler to remove temporary files deposited by @@ -382,9 +375,9 @@ defaultCleanupHandler dflags inner = -- %************************************************************************ --- %* * +-- %* * -- The Ghc Monad --- %* * +-- %* * -- %************************************************************************ -- | Run function for the 'Ghc' monad. @@ -450,9 +443,9 @@ initGhcMonad mb_top_dir = do -- %************************************************************************ --- %* * +-- %* * -- Flags & settings --- %* * +-- %* * -- %************************************************************************ -- | Updates the DynFlags in a Session. This also reads @@ -480,9 +473,9 @@ parseDynamicFlags = parseDynamicFlagsCmdLine -- %************************************************************************ --- %* * +-- %* * -- Setting, getting, and modifying the targets --- %* * +-- %* * -- %************************************************************************ -- ToDo: think about relative vs. absolute file paths. And what @@ -530,13 +523,13 @@ guessTarget str Nothing = return (target (TargetFile file Nothing)) | otherwise = do exists <- liftIO $ doesFileExist hs_file - if exists - then return (target (TargetFile hs_file Nothing)) - else do - exists <- liftIO $ doesFileExist lhs_file - if exists - then return (target (TargetFile lhs_file Nothing)) - else do + if exists + then return (target (TargetFile hs_file Nothing)) + else do + exists <- liftIO $ doesFileExist lhs_file + if exists + then return (target (TargetFile lhs_file Nothing)) + else do if looksLikeModuleName file then return (target (TargetModule (mkModuleName file))) else do @@ -549,8 +542,8 @@ guessTarget str Nothing | '*':rest <- str = (rest, False) | otherwise = (str, True) - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" target tid = Target tid obj_allowed Nothing @@ -567,9 +560,9 @@ workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) -- %************************************************************************ --- %* * +-- %* * -- Running phases one at a time --- %* * +-- %* * -- %************************************************************************ class ParsedMod m where @@ -581,11 +574,11 @@ class ParsedMod m => TypecheckedMod m where typecheckedSource :: m -> TypecheckedSource moduleInfo :: m -> ModuleInfo tm_internals :: m -> (TcGblEnv, ModDetails) - -- ToDo: improvements that could be made here: - -- if the module succeeded renaming but not typechecking, - -- we can still get back the GlobalRdrEnv and exports, so - -- perhaps the ModuleInfo should be split up into separate - -- fields. + -- ToDo: improvements that could be made here: + -- if the module succeeded renaming but not typechecking, + -- we can still get back the GlobalRdrEnv and exports, so + -- perhaps the ModuleInfo should be split up into separate + -- fields. class TypecheckedMod m => DesugaredMod m where coreModule :: m -> ModGuts @@ -768,9 +761,9 @@ loadModule tcm = do -- %************************************************************************ --- %* * +-- %* * -- Dealing with Core --- %* * +-- %* * -- %************************************************************************ -- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for @@ -819,7 +812,7 @@ compileToCore fn = do compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m () compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do dflags <- getSessionDynFlags - currentTime <- liftIO $ getClockTime + currentTime <- liftIO $ getCurrentTime cwd <- liftIO $ getCurrentDirectory modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd ((moduleNameSlashes . moduleName) mName) @@ -893,9 +886,9 @@ compileCore simplify fn = do } -- %************************************************************************ --- %* * +-- %* * -- Inspecting the session --- %* * +-- %* * -- %************************************************************************ -- | Get the module dependency graph. @@ -922,7 +915,7 @@ getBindings = withSession $ \hsc_env -> return $ icInScopeTTs $ hsc_IC hsc_env -- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([Instance], [FamInst]) +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env -> return $ ic_instances (hsc_IC hsc_env) @@ -932,28 +925,28 @@ getPrintUnqual = withSession $ \hsc_env -> -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? - minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance], + minf_type_env :: TypeEnv, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? + minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod + minf_instances :: [ClsInst], minf_iface :: Maybe ModIface #ifdef GHCI ,minf_modBreaks :: ModBreaks #endif } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. -- | Request information about a loaded 'Module' getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env mdl - else do + then liftIO $ getHomeModuleInfo hsc_env mdl + else do {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl + then return Nothing + else -} liftIO $ getPackageModuleInfo hsc_env mdl -- ToDo: we don't understand what the following comment means. -- (SDM, 19/7/2011) -- getPackageModuleInfo will attempt to find the interface, so @@ -964,23 +957,23 @@ getModuleInfo mdl = withSession $ \hsc_env -> do getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env + = do eps <- hscEPS hsc_env iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface + let + avails = mi_exports iface names = availsToNameSet avails - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = names, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + -- + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = names, + minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, minf_modBreaks = emptyModBreaks - })) + })) #else -- bogusly different for non-GHCI (ToDo) getPackageModuleInfo _hsc_env _mdl = do @@ -995,15 +988,15 @@ getHomeModuleInfo hsc_env mdl = let details = hm_details hmi iface = hm_iface hmi return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = availsToNameSet (md_exports details), - minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details, + minf_type_env = md_types details, + minf_exports = availsToNameSet (md_exports details), + minf_rdr_env = mi_globals $! hm_iface hmi, + minf_instances = md_insts details, minf_iface = Just iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif - })) + })) -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] @@ -1018,7 +1011,7 @@ modInfoExports minf = nameSetToList $! minf_exports minf -- | Returns the instances defined by the specified module. -- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [Instance] +modInfoInstances :: ModuleInfo -> [ClsInst] modInfoInstances = minf_instances modInfoIsExportedName :: ModuleInfo -> Name -> Bool @@ -1039,7 +1032,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do Nothing -> do eps <- liftIO $ readIORef (hsc_EPS hsc_env) return $! lookupType (hsc_dflags hsc_env) - (hsc_HPT hsc_env) (eps_PTE eps) name + (hsc_HPT hsc_env) (eps_PTE eps) name modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface @@ -1252,28 +1245,34 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do res <- findExposedPackageModule hsc_env mod_name Nothing case res of Found _ m -> return m - err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err -lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing #ifdef GHCI +-- | Check that a module is safe to import (according to Safe Haskell). +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an error may be thrown first. +isModuleTrusted :: GhcMonad m => Module -> m Bool +isModuleTrusted m = withSession $ \hsc_env -> + liftIO $ hscCheckSafe hsc_env m noSrcSpan + getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> - return$ InteractiveEval.getHistorySpan hsc_env h + return $ InteractiveEval.getHistorySpan hsc_env h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term -obtainTermFromVal bound force ty a = - withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a +obtainTermFromVal bound force ty a = withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term -obtainTermFromId bound force id = - withSession $ \hsc_env -> - liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id +obtainTermFromId bound force id = withSession $ \hsc_env -> + liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id #endif @@ -1307,3 +1306,4 @@ parser str dflags filename = POk pst rdr_module -> let (warns,_) = getMessages pst in Right (warns, rdr_module) + diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 3db920553e..a2fb9edf16 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -62,15 +62,15 @@ import UniqFM import qualified Data.Map as Map import qualified FiniteMap as Map( insertListWith) -import System.Directory ( doesFileExist, getModificationTime ) +import System.Directory import System.IO ( fixIO ) import System.IO.Error ( isDoesNotExistError ) -import System.Time ( ClockTime ) import System.FilePath import Control.Monad import Data.Maybe import Data.List import qualified Data.List as List +import Data.Time -- ----------------------------------------------------------------------------- -- Loading the program @@ -1200,7 +1200,7 @@ summariseFile -> FilePath -- source file name -> Maybe Phase -- start phase -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) + -> Maybe (StringBuffer,UTCTime) -> IO ModSummary summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf @@ -1214,10 +1214,10 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- return the cached summary if the source didn't change src_timestamp <- case maybe_buf of Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file + Nothing -> liftIO $ getModificationUTCTime file -- The file exists; we checked in getRootSummary above. -- If it gets removed subsequently, then this - -- getModificationTime may fail, but that's the right + -- getModificationUTCTime may fail, but that's the right -- behaviour. if ms_hs_date old_summary == src_timestamp @@ -1251,7 +1251,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf src_timestamp <- case maybe_buf of Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file + Nothing -> liftIO $ getModificationUTCTime file -- getMofificationTime may fail -- when the user asks to load a source file by name, we only @@ -1285,7 +1285,7 @@ summariseModule -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? - -> Maybe (StringBuffer, ClockTime) + -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary @@ -1306,7 +1306,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) case maybe_buf of Just (_,t) -> check_timestamp old_summary location src_fn t Nothing -> do - m <- tryIO (getModificationTime src_fn) + m <- tryIO (getModificationUTCTime src_fn) case m of Right t -> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it @@ -1398,7 +1398,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ms_obj_date = obj_timestamp })) -getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot then return Nothing else modificationTimeIfExists (ml_obj_file location) @@ -1407,7 +1407,7 @@ getObjTimestamp location is_boot preprocessFile :: HscEnv -> FilePath -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) + -> Maybe (StringBuffer,UTCTime) -> IO (DynFlags, FilePath, StringBuffer) preprocessFile hsc_env src_fn mb_phase Nothing = do diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 816cc4b922..6b8c7bacdf 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -46,11 +46,10 @@ import Data.IORef -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. -- -class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where getSession :: m HscEnv setSession :: HscEnv -> m () - -- | Call the argument with the current session. withSession :: GhcMonad m => (HscEnv -> m a) -> m a withSession f = getSession >>= f @@ -120,6 +119,9 @@ instance ExceptionMonad Ghc where in unGhc (f g_restore) s +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + instance GhcMonad Ghc where getSession = Ghc $ \(Session r) -> readIORef r setSession s' = Ghc $ \(Session r) -> writeIORef r s' @@ -176,6 +178,9 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where in unGhcT (f g_restore) s +instance (Functor m, ExceptionMonad m, MonadIO m) => HasDynFlags (GhcT m) where + getDynFlags = getSessionDynFlags + instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where getSession = GhcT $ \(Session r) -> liftIO $ readIORef r setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 9fad73a9f8..6322024c9e 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -123,7 +123,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls ideclAs = Nothing, ideclHiding = Nothing } -parseError :: SrcSpan -> Message -> IO a +parseError :: SrcSpan -> MsgDoc -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err -------------------------------------------------------------- diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index b95ede9127..bdb26dfb38 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -60,6 +60,7 @@ module HscMain , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo + , hscCheckSafe #ifdef GHCI , hscGetModuleInterface , hscRnImportDecls @@ -83,6 +84,8 @@ import DsMeta ( templateHaskellNames ) import VarSet import VarEnv ( emptyTidyEnv ) import Panic + +import GHC.Exts #endif import Id @@ -93,7 +96,7 @@ import HsSyn import CoreSyn import StringBuffer import Parser -import Lexer hiding (getDynFlags) +import Lexer import SrcLoc import TcRnDriver import TcIface ( typecheckIface ) @@ -210,6 +213,9 @@ instance Monad Hsc where instance MonadIO Hsc where liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) +instance Functor Hsc where + fmap f m = m >>= \a -> return $ f a + runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag @@ -228,8 +234,8 @@ logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) -getDynFlags :: Hsc DynFlags -getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) handleWarnings :: Hsc () handleWarnings = do @@ -267,7 +273,7 @@ throwErrors = liftIO . throwIO . mkSrcErr -- failed, it must have been due to the warnings (i.e., @-Werror@). ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO $ ioA + ((warns,errs), mb_r) <- liftIO ioA logWarnings warns case mb_r of Nothing -> throwErrors errs @@ -297,7 +303,7 @@ hscTcRcLookupName hsc_env name = -- "name not found", and the Maybe in the return type -- is used to indicate that. -hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance])) +hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst])) hscTcRnGetInfo hsc_env name = runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name @@ -845,8 +851,7 @@ hscFileFrontEnd mod_summary = do return tcg_env' where pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = text "Warning:" <+> quotes (pprMod t) - <+> text "has been infered as safe!" + errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" -------------------------------------------------------------- -- Safe Haskell @@ -891,9 +896,8 @@ hscFileFrontEnd mod_summary = do -- inference mode. hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv hscCheckSafeImports tcg_env = do - hsc_env <- getHscEnv dflags <- getDynFlags - tcg_env' <- checkSafeImports dflags hsc_env tcg_env + tcg_env' <- checkSafeImports dflags tcg_env case safeLanguageOn dflags of True -> do -- we nuke user written RULES in -XSafe @@ -916,22 +920,20 @@ hscCheckSafeImports tcg_env = do text "Rule \"" <> ftext n <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" --- | Validate that safe imported modules are actually safe. --- For modules in the HomePackage (the package the module we --- are compiling in resides) this just involves checking its --- trust type is 'Safe' or 'Trustworthy'. For modules that --- reside in another package we also must check that the --- external pacakge is trusted. See the Note [Safe Haskell --- Trust Check] above for more information. +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external pacakge +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. -- --- The code for this is quite tricky as the whole algorithm --- is done in a few distinct phases in different parts of the --- code base. See RnNames.rnImportDecl for where package trust --- dependencies for a module are collected and unioned. --- Specifically see the Note [RnNames . Tracking Trust Transitively] --- and the Note [RnNames . Trust Own Package]. -checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv -checkSafeImports dflags hsc_env tcg_env +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- RnNames.rnImportDecl for where package trust dependencies for a module are +-- collected and unioned. Specifically see the Note [RnNames . Tracking Trust +-- Transitively] and the Note [RnNames . Trust Own Package]. +checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv +checkSafeImports dflags tcg_env = do -- We want to use the warning state specifically for detecting if safe -- inference has failed, so store and clear any existing warnings. @@ -946,7 +948,7 @@ checkSafeImports dflags hsc_env tcg_env clearWarnings logWarnings oldErrs - -- See the Note [ Safe Haskell Inference] + -- See the Note [Safe Haskell Inference] case (not $ isEmptyBag errs) of -- We have errors! @@ -958,7 +960,7 @@ checkSafeImports dflags hsc_env tcg_env -- All good matey! False -> do - when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs + when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs -- add in trusted package requirements for this module let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust } @@ -986,41 +988,36 @@ checkSafeImports dflags hsc_env tcg_env (text $ "is imported both as a safe and unsafe import!")) | otherwise = return v1 + + -- easier interface to work with + checkSafe (_, _, False) = return Nothing + checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l - lookup' :: Module -> Hsc (Maybe ModIface) - lookup' m = do - hsc_eps <- liftIO $ hscEPS hsc_env - let pkgIfaceT = eps_PIT hsc_eps - homePkgT = hsc_HPT hsc_env - iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m - return iface - - isHomePkg :: Module -> Bool - isHomePkg m - | thisPackage dflags == modulePackageId m = True - | otherwise = False - - -- | Check the package a module resides in is trusted. - -- Safe compiled modules are trusted without requiring - -- that their package is trusted. For trustworthy modules, - -- modules in the home package are trusted but otherwise - -- we check the package trust flag. - packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted Sf_Safe False _ = True - packageTrusted Sf_SafeInfered False _ = True - packageTrusted _ _ m - | isHomePkg m = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageId m) - - -- Is a module trusted? Return Nothing if True, or a String - -- if it isn't, containing the reason it isn't. Also return - -- if the module trustworthy (true) or safe (false) so we know - -- if we should check if the package itself is trusted in the - -- future. - isModSafe :: Module -> SrcSpan -> Hsc (Bool) +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' dflags m l + when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs + errs <- getWarnings + return $ isEmptyBag errs + +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId]) +hscCheckSafe' dflags m l = do + (tw, pkgs) <- isModSafe m l + case tw of + False -> return (Nothing, pkgs) + True | isHomePkg m -> return (Nothing, pkgs) + | otherwise -> return (Just $ modulePackageId m, pkgs) + where + -- Is a module trusted? If not, throw or log errors depending on the type. + -- Return (regardless of trusted or not) if the trust type requires the + -- modules own package be trusted and a list of other packages required to + -- be trusted (these later ones haven't been checked) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId]) isModSafe m l = do iface <- lookup' m case iface of @@ -1037,11 +1034,14 @@ checkSafeImports dflags hsc_env tcg_env safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m + -- pkg trust reqs + pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface' case (safeM, safeP) of -- General errors we throw but Safe errors we log - (True, True ) -> return $ trust == Sf_Trustworthy + (True, True ) -> return (trust == Sf_Trustworthy, pkgRs) (True, False) -> liftIO . throwIO $ pkgTrustErr - (False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy) + (False, _ ) -> logWarnings modTrustErr >> + return (trust == Sf_Trustworthy, pkgRs) where pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m @@ -1052,30 +1052,60 @@ checkSafeImports dflags hsc_env tcg_env <+> text "can't be safely imported!" <+> text "The module itself isn't safe." - -- Here we check the transitive package trust requirements are OK still. - checkPkgTrust :: [PackageId] -> Hsc () - checkPkgTrust pkgs = - case errors of - [] -> return () - _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors - where - errors = catMaybes $ map go pkgs - go pkg - | trusted $ getPackageDetails (pkgState dflags) pkg - = Nothing - | otherwise - = Just $ mkPlainErrMsg noSrcSpan - $ text "The package (" <> ppr pkg <> text ") is required" - <> text " to be trusted but it isn't!" - - checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId) - checkSafe (_, _, False) = return Nothing - checkSafe (m, l, True ) = do - tw <- isModSafe m l - return $ pkg tw - where pkg False = Nothing - pkg True | isHomePkg m = Nothing - | otherwise = Just (modulePackageId m) + -- | Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted Sf_Safe False _ = True + packageTrusted Sf_SafeInfered False _ = True + packageTrusted _ _ m + | isHomePkg m = True + | otherwise = trusted $ getPackageDetails (pkgState dflags) + (modulePackageId m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m +#ifdef GHCI + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + iface' <- case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + return iface' +#else + return iface +#endif + + + isHomePkg :: Module -> Bool + isHomePkg m + | thisPackage dflags == modulePackageId m = True + | otherwise = False + +-- | Check the list of packages are trusted. +checkPkgTrust :: DynFlags -> [PackageId] -> Hsc () +checkPkgTrust dflags pkgs = + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + where + errors = catMaybes $ map go pkgs + go pkg + | trusted $ getPackageDetails (pkgState dflags) pkg + = Nothing + | otherwise + = Just $ mkPlainErrMsg noSrcSpan + $ text "The package (" <> ppr pkg <> text ") is required" + <> text " to be trusted but it isn't!" -- | Set module to unsafe and wipe trust information. -- @@ -1096,8 +1126,7 @@ wipeTrust tcg_env whyUnsafe = do where wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' = vcat [ text "Warning:" <+> quotes pprMod - <+> text "has been infered as unsafe!" + whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!" , text "Reason:" , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ] @@ -1366,72 +1395,58 @@ myCoreToStg dflags this_mod prepd_binds = do %********************************************************************* -} {- -When the UnlinkedBCOExpr is linked you get an HValue of type - IO [HValue] -When you run it you get a list of HValues that should be -the same length as the list of names; add them to the ClosureEnv. - -A naked expression returns a singleton Name [it]. - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ v -> return [v] - [NB: result not printed] bindings: [it] - - - expr (of non-IO type, - result showable) ==> let v = expr in print v >> return [v] - bindings: [it] - - expr (of non-IO type, - result not showable) ==> error +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver -} #ifdef GHCI -- | Compile a stmt all the way to an HValue, but don't run it -hscStmt :: HscEnv - -> String -- ^ The statement - -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement - -- (or comment only), but no parse error +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue])) hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 -- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. hscStmtWithLocation :: HscEnv -> String -- ^ The statement -> String -- ^ The source -> Int -- ^ Starting line - -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement - -- (or comment only), but no parse error + -> IO (Maybe ([Id], IO [HValue])) hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing - -- The real stuff Just parsed_stmt -> do - -- Rename and typecheck it - let icontext = hsc_IC hsc_env - (ids, tc_expr) <- ioMsgMaybe $ - tcRnStmt hsc_env icontext parsed_stmt + let icntxt = hsc_IC hsc_env + rdr_env = ic_rn_gbl_env icntxt + type_env = mkTypeEnvWithImplicits (ic_tythings icntxt) + src_span = srcLocSpan interactiveSrcLoc + + -- Rename and typecheck it + -- Here we lift the stmt into the IO monad, see Note + -- [Interactively-bound Ids in GHCi] in TcRnDriver + (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt + -- Desugar it - let rdr_env = ic_rn_gbl_env icontext - type_env = mkTypeEnvWithImplicits (ic_tythings icontext) ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr handleWarnings -- Then code-gen, and link it - let src_span = srcLocSpan interactiveSrcLoc hsc_env <- getHscEnv hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + let hval_io = unsafeCoerce# hval :: IO [HValue] - return $ Just (ids, hval) + return $ Just (ids, hval_io) -- | Compile a decls hscDecls :: HscEnv @@ -1457,8 +1472,8 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do -- We grab the whole environment because of the overlapping that may have -- been done. See the notes at the definition of InteractiveContext -- (ic_instances) for more details. - let finsts = famInstEnvElts $ tcg_fam_inst_env tc_gblenv - insts = instEnvElts $ tcg_inst_env tc_gblenv + let finsts = tcg_fam_insts tc_gblenv + insts = tcg_insts tc_gblenv {- Desugar it -} -- We use a basically null location for iNTERACTIVE @@ -1575,7 +1590,7 @@ hscParseThingWithLocation source linenumber parser str liftIO $ showPass dflags "Parser" let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 + loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of PFailed span err -> do diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index f89903f75c..168e49af4a 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -52,7 +52,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ("DataDecls ", data_ds), ("NewTypeDecls ", newt_ds), ("TypeFamilyDecls ", type_fam_ds), - ("FamilyInstDecls ", fam_inst_ds), ("DataConstrs ", data_constrs), ("DataDerivings ", data_derivs), ("ClassDecls ", class_ds), @@ -89,7 +88,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, type_ds, data_ds, newt_ds, type_fam_ds, fam_inst_ds) = + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] @@ -153,7 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs ats) + inst_info (FamInstDecl d) = case countATDecl d of + (tyd, dtd) -> (0,0,0,tyd,dtd) + inst_info (ClsInstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of @@ -162,9 +163,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is, tyDecl, dtDecl) where - countATDecl (TyData {}) = (0, 1) - countATDecl (TySynonym {}) = (1, 0) - countATDecl d = pprPanic "countATDecl: Unhandled decl" + countATDecl (TyData {}) = (0, 1) + countATDecl (TySynonym {}) = (1, 0) + countATDecl d = pprPanic "countATDecl: Unhandled decl" (ppr d) addpr :: (Int,Int) -> Int diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6b389fd1b2..9840b407ce 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -92,7 +92,7 @@ module HscTypes ( -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo, + noIfaceVectInfo, isNoIfaceVectInfo, -- * Safe Haskell information hscGetSafeInf, hscSetSafeInf, @@ -119,7 +119,7 @@ import HsSyn import RdrName import Avail import Module -import InstEnv ( InstEnv, Instance ) +import InstEnv ( InstEnv, ClsInst ) import FamInstEnv import Rules ( RuleBase ) import CoreSyn ( CoreProgram ) @@ -164,11 +164,11 @@ import Control.Monad ( mplus, guard, liftM, when ) import Data.Array ( Array, array ) import Data.IORef import Data.Map ( Map ) +import Data.Time import Data.Word import Data.Typeable ( Typeable ) import Exception import System.FilePath -import System.Time ( ClockTime ) -- ----------------------------------------------------------------------------- -- Source Errors @@ -238,12 +238,12 @@ printOrThrowWarnings dflags warns = when (not (isEmptyBag warns)) $ do throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg | otherwise - = printBagOfWarnings dflags warns + = printBagOfErrors dflags warns handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns = when (wopt Opt_WarnDeprecatedFlags dflags) $ do - -- It would be nicer if warns :: [Located Message], but that + -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. let bag = listToBag [ mkPlainWarnMsg loc (text warn) | L loc warn <- warns ] @@ -356,7 +356,7 @@ data Target = Target { targetId :: TargetId, -- ^ module or filename targetAllowObjCode :: Bool, -- ^ object code allowed? - targetContents :: Maybe (StringBuffer,ClockTime) + targetContents :: Maybe (StringBuffer,UTCTime) -- ^ in-memory text buffer? } @@ -467,7 +467,7 @@ lookupIfaceByModule dflags hpt pit mod -- modules imported by this one, directly or indirectly, and are in the Home -- Package Table. This ensures that we don't see instances from modules @--make@ -- compiled before this one, but which are not below this one. -hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst]) +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) hptInstances hsc_env want_this_module = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) @@ -693,11 +693,11 @@ data ModIface -- 'HomeModInfo', but that leads to more plumbing. -- Instance declarations and rules - mi_insts :: [IfaceInst], -- ^ Sorted class instance + mi_insts :: [IfaceClsInst], -- ^ Sorted class instance mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances mi_rules :: [IfaceRule], -- ^ Sorted rules - mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules and class - -- and family instances combined + mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family + -- instances, and vectorise pragmas combined mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information @@ -771,7 +771,7 @@ data ModDetails -- The next two fields are created by the typechecker md_exports :: [AvailInfo], md_types :: !TypeEnv, -- ^ Local type environment for this particular module - md_insts :: ![Instance], -- ^ 'DFunId's for the instances in this module + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently @@ -817,7 +817,7 @@ data ModGuts -- ToDo: I'm unconvinced this is actually used anywhere mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) - mg_insts :: ![Instance], -- ^ Class instances declared in this module + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains -- See Note [Overall plumbing for rules] in Rules.lhs @@ -931,13 +931,14 @@ data InteractiveContext ic_tythings :: [TyThing], -- ^ TyThings defined by the user, in reverse order of - -- definition. + -- definition. At a breakpoint, this list includes the + -- local variables in scope at that point ic_sys_vars :: [Id], -- ^ Variables defined automatically by the system (e.g. -- record field selectors). See Notes [ic_sys_vars] - ic_instances :: ([Instance], [FamInst]), + ic_instances :: ([ClsInst], [FamInst]), -- ^ All instances and family instances created during -- this session. These are grabbed en masse after each -- update to be sure that proper overlapping is retained. @@ -1163,10 +1164,34 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) %************************************************************************ %* * - TyThing + Implicit TyThings %* * %************************************************************************ +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implict. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). + \begin{code} -- | Determine the 'TyThing's brought into scope by another 'TyThing' -- /other/ than itself. For example, Id's don't have any implicit TyThings @@ -1175,7 +1200,7 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) -- scope, just for a start! -- N.B. the set of TyThings returned here *must* match the set of --- names returned by LoadIface.ifaceDeclSubBndrs, in the sense that +-- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. @@ -1201,9 +1226,10 @@ implicitTyConThings :: TyCon -> [TyThing] implicitTyConThings tc = class_stuff ++ -- fields (names of selectors) - -- (possibly) implicit coercion and family coercion - -- depending on whether it's a newtype or a family instance or both + + -- (possibly) implicit newtype coercion implicitCoTyCon tc ++ + -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) @@ -1218,14 +1244,11 @@ implicitTyConThings tc extras_plus :: TyThing -> [TyThing] extras_plus thing = thing : implicitTyThings thing --- For newtypes and indexed data types (and both), --- add the implicit coercion tycon +-- For newtypes (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc - = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not - newTyConCo_maybe tc, - -- Just if family instance, Nothing if not - tyConFamilyCoercion_maybe tc] + | Just co <- newTyConCo_maybe tc = [ACoAxiom co] + | otherwise = [] -- | Returns @True@ if there should be no interface-file declaration -- for this thing on its own: either it is built-in, or it is part @@ -1235,7 +1258,7 @@ isImplicitTyThing :: TyThing -> Bool isImplicitTyThing (ADataCon {}) = True isImplicitTyThing (AnId id) = isImplicitId id isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc -isImplicitTyThing (ACoAxiom {}) = True +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax -- | tyThingParent_maybe x returns (Just p) -- when pprTyThingInContext sould print a declaration for p @@ -1321,13 +1344,14 @@ mkTypeEnvWithImplicits things = mkTypeEnv (concatMap implicitTyThings things) typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv -typeEnvFromEntities ids tcs faminsts = +typeEnvFromEntities ids tcs famInsts = mkTypeEnv ( map AnId ids ++ map ATyCon all_tcs ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . famInstAxiom) famInsts ) where - all_tcs = tcs ++ map famInstTyCon faminsts + all_tcs = tcs ++ famInstsRepTyCons famInsts lookupTypeEnv = lookupNameEnv @@ -1363,8 +1387,9 @@ lookupType dflags hpt pte name lookupNameEnv (md_types (hm_details hm)) name | otherwise = lookupNameEnv pte name - where mod = ASSERT( isExternalName name ) nameModule name - this_pkg = thisPackage dflags + where + mod = ASSERT2( isExternalName name, ppr name ) nameModule name + this_pkg = thisPackage dflags -- | As 'lookupType', but with a marginally easier-to-use interface -- if you have a 'HscEnv' @@ -1432,7 +1457,7 @@ mkIfaceHashCache pairs = \occ -> lookupOccEnv env occ where env = foldr add_decl emptyOccEnv pairs - add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d) + add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclImplicitBndrs d) where decl_name = ifName d env1 = extendOccEnv env0 decl_name (decl_name, v) @@ -1543,6 +1568,8 @@ lookupFixity env n = case lookupNameEnv env n of -- -- * A transformation rule in a module other than the one defining -- the function in the head of the rule +-- +-- * A vectorisation pragma type WhetherHasOrphans = Bool -- | Does this module define family instances? @@ -1609,7 +1636,7 @@ data Usage } -- ^ Module from the current package | UsageFile { usg_file_path :: FilePath, - usg_mtime :: ClockTime + usg_mtime :: UTCTime -- ^ External file dependency. From a CPP #include or TH addDependentFile. Should be absolute. } deriving( Eq ) @@ -1780,8 +1807,8 @@ data ModSummary ms_mod :: Module, -- ^ Identity of the module ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: ClockTime, -- ^ Timestamp of source file - ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one + ms_hs_date :: UTCTime, -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, -- ^ Timestamp of object, if we have one ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text* ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file @@ -1986,6 +2013,10 @@ concatVectInfo = foldr plusVectInfo noVectInfo noIfaceVectInfo :: IfaceVectInfo noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] +isNoIfaceVectInfo :: IfaceVectInfo -> Bool +isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5) + = null l1 && null l2 && null l3 && null l4 && null l5 + instance Outputable VectInfo where ppr info = vcat [ ptext (sLit "variables :") <+> ppr (vectInfoVar info) @@ -2077,7 +2108,7 @@ stuff is the *dynamic* linker, and isn't present in a stage-1 compiler \begin{code} -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { - linkableTime :: ClockTime, -- ^ Time at which this linkable was built + linkableTime :: UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) linkableModule :: Module, -- ^ The linkable module itself diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index b4cf6b8197..cdc2ca501a 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -6,17 +6,10 @@ -- -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, @@ -25,18 +18,18 @@ module InteractiveEval ( getModBreaks, getHistoryModule, back, forward, - setContext, getContext, + setContext, getContext, availsToGlobalRdrEnv, - getNamesInScope, - getRdrNamesInScope, - moduleIsInterpreted, - getInfo, - exprType, - typeKind, - parseName, - showModule, + getNamesInScope, + getRdrNamesInScope, + moduleIsInterpreted, + getInfo, + exprType, + typeKind, + parseName, + showModule, isModuleInterpreted, - compileExpr, dynCompileExpr, + compileExpr, dynCompileExpr, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType #endif ) where @@ -51,7 +44,7 @@ import HsSyn import HscTypes import InstEnv import Type hiding( typeKind ) -import TcType hiding( typeKind ) +import TcType hiding( typeKind ) import Var import Id import Name hiding ( varName ) @@ -98,7 +91,7 @@ import System.IO.Unsafe -- running a statement interactively data RunResult - = RunOk [Name] -- ^ names bound by this evaluation + = RunOk [Name] -- ^ names bound by this evaluation | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) @@ -112,13 +105,13 @@ data Resume = Resume { resumeStmt :: String, -- the original statement resumeThreadId :: ThreadId, -- thread running the computation - resumeBreakMVar :: MVar (), + resumeBreakMVar :: MVar (), resumeStatMVar :: MVar Status, resumeBindings :: ([TyThing], GlobalRdrEnv), resumeFinalIds :: [Id], -- [Id] to bind on completion resumeApStack :: HValue, -- The object from which we can get -- value of the free variables. - resumeBreakInfo :: Maybe BreakInfo, + resumeBreakInfo :: Maybe BreakInfo, -- the breakpoint we stopped at -- (Nothing <=> exception) resumeSpan :: SrcSpan, -- just a cache, otherwise it's a pain @@ -191,8 +184,8 @@ runStmt = runStmtWithLocation "<interactive>" 1 -- | Run a statement in the current interactive context. Passing debug information -- Statement may bind multple values. -runStmtWithLocation :: GhcMonad m => String -> Int -> - String -> SingleStep -> m RunResult +runStmtWithLocation :: GhcMonad m => String -> Int -> + String -> SingleStep -> m RunResult runStmtWithLocation source linenumber expr step = do hsc_env <- getSession @@ -205,18 +198,19 @@ runStmtWithLocation source linenumber expr step = let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } + -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber case r of - Nothing -> return (RunOk []) -- empty statement / comment + -- empty statement / comment + Nothing -> return (RunOk []) Just (tyThings, hval) -> do status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - liftIO $ sandboxIO dflags' statusMVar thing_to_run - + liftIO $ sandboxIO dflags' statusMVar hval + let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -242,7 +236,7 @@ runDeclsWithLocation source linenumber expr = hsc_env' = hsc_env{ hsc_dflags = dflags' } (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber - + setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession hsc_env' <- liftIO $ rttiEnvironment hsc_env @@ -257,7 +251,7 @@ withVirtualCWD m = do let set_cwd = do dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of + case ic_cwd ic of Just dir -> liftIO $ setCurrentDirectory dir Nothing -> return () return dir @@ -283,7 +277,7 @@ handleRunStatus :: GhcMonad m => -> m RunResult handleRunStatus expr bindings final_ids breakMVar statusMVar status history = - case status of + case status of -- did we hit a breakpoint or did we complete? (Break is_exception apStack info tid) -> do hsc_env <- getSession @@ -293,9 +287,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status mb_info let resume = Resume { resumeStmt = expr, resumeThreadId = tid - , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar + , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_info + , resumeApStack = apStack, resumeBreakInfo = mb_info , resumeSpan = span, resumeHistory = toListBL history , resumeHistoryIx = 0 } hsc_env2 = pushResume hsc_env1 resume @@ -303,9 +297,9 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status modifySession (\_ -> hsc_env2) return (RunBreak tid names mb_info) (Complete either_hvals) -> - case either_hvals of - Left e -> return (RunException e) - Right hvals -> do + case either_hvals of + Left e -> return (RunException e) + Right hvals -> do hsc_env <- getSession let final_ic = extendInteractiveContext (hsc_IC hsc_env) (map AnId final_ids) @@ -369,8 +363,8 @@ resetStepFlag :: IO () resetStepFlag = poke stepFlag 0 -- this points to the IO action that is executed when a breakpoint is hit -foreign import ccall "&rts_breakpoint_io_action" - breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) +foreign import ccall "&rts_breakpoint_io_action" + breakPointIOAction :: Ptr (StablePtr (Bool -> BreakInfo -> HValue -> IO ())) -- When running a computation, we redirect ^C exceptions to the running -- thread. ToDo: we might want a way to continue even if the target @@ -407,7 +401,7 @@ sandboxIO dflags statusMVar thing = rethrow :: DynFlags -> IO a -> IO a rethrow dflags io = Exception.catch io $ \se -> do -- If -fbreak-on-error, we break unconditionally, - -- but with care of not breaking twice + -- but with care of not breaking twice if dopt Opt_BreakOnError dflags && not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 @@ -481,28 +475,28 @@ resume canLogSpan step ic_rn_gbl_env = resume_rdr_env, ic_resume = rs } modifySession (\_ -> hsc_env{ hsc_IC = ic' }) - - -- remove any bindings created since the breakpoint from the + + -- remove any bindings created since the breakpoint from the -- linker's environment let new_names = map getName (filter (`notElem` resume_tmp_te) (ic_tythings ic)) liftIO $ Linker.deleteFromLinkEnv new_names - + when (isStep step) $ liftIO setStepFlag - case r of + case r of Resume { resumeStmt = expr, resumeThreadId = tid , resumeBreakMVar = breakMVar, resumeStatMVar = statusMVar , resumeBindings = bindings, resumeFinalIds = final_ids , resumeApStack = apStack, resumeBreakInfo = info, resumeSpan = span , resumeHistory = hist } -> do withVirtualCWD $ do - withBreakAction (isStep step) (hsc_dflags hsc_env) + withBreakAction (isStep step) (hsc_dflags hsc_env) breakMVar statusMVar $ do status <- liftIO $ withInterruptsSentTo tid $ do putMVar breakMVar () -- this awakens the stopped thread... takeMVar statusMVar - -- and wait for the result + -- and wait for the result let prevHistoryLst = fromListBL 50 hist hist' = case info of Nothing -> prevHistoryLst @@ -511,7 +505,7 @@ resume canLogSpan step | otherwise -> mkHistory hsc_env apStack i `consBL` fromListBL 50 hist case step of - RunAndLogSteps -> + RunAndLogSteps -> traceRunStatus expr bindings final_ids breakMVar statusMVar status hist' _other -> @@ -543,23 +537,23 @@ moveHist fn = do update_ic apStack mb_info = do (hsc_env1, names, span) <- liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info - let ic = hsc_IC hsc_env1 + let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } - + modifySession (\_ -> hsc_env1{ hsc_IC = ic' }) - + return (names, new_ix, span) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to -- make this the case. ToDo: this is v. fragile, do something better. if new_ix == 0 - then case r of - Resume { resumeApStack = apStack, + then case r of + Resume { resumeApStack = apStack, resumeBreakInfo = mb_info } -> update_ic apStack mb_info - else case history !! (new_ix - 1) of + else case history !! (new_ix - 1) of History apStack info _ -> update_ic apStack (Just info) @@ -598,9 +592,9 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do -- of the breakpoint and the free variables of the expression. bindLocalsAtBreakpoint hsc_env apStack (Just info) = do - let + let mod_name = moduleName (breakInfo_module info) - hmi = expectJust "bindLocalsAtBreakpoint" $ + hmi = expectJust "bindLocalsAtBreakpoint" $ lookupUFM (hsc_HPT hsc_env) mod_name breaks = getModBreaks hmi index = breakInfo_number info @@ -628,7 +622,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ - text "Warning: _result has been evaluated, some bindings have been lost" + text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' let (us1, us2) = splitUniqSupply us @@ -683,10 +677,10 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do | (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us , let name = setNameUnique (tyVarName tv) uniq ] -rttiEnvironment :: HscEnv -> IO HscEnv +rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let tmp_ids = [id | AnId id <- ic_tythings ic] - incompletelyTypedIds = + incompletelyTypedIds = [id | id <- tmp_ids , not $ noSkolems id , (occNameFS.nameOccName.idName) id /= result_fs] @@ -744,7 +738,7 @@ abandon = do resume = ic_resume ic case resume of [] -> return False - r:rs -> do + r:rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = rs } } liftIO $ abandon_ r return True @@ -756,13 +750,13 @@ abandonAll = do resume = ic_resume ic case resume of [] -> return False - rs -> do + rs -> do modifySession $ \_ -> hsc_env{ hsc_IC = ic { ic_resume = [] } } liftIO $ mapM_ abandon_ rs return True --- when abandoning a computation we have to --- (a) kill the thread with an async exception, so that the +-- when abandoning a computation we have to +-- (a) kill the thread with an async exception, so that the -- computation itself is stopped, and -- (b) fill in the MVar. This step is necessary because any -- thunks that were under evaluation will now be updated @@ -773,7 +767,7 @@ abandonAll = do abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) - putMVar (resumeBreakMVar r) () + putMVar (resumeBreakMVar r) () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons @@ -821,7 +815,7 @@ findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls - -- This call also loads any orphan modules + -- This call also loads any orphan modules ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } where @@ -838,21 +832,21 @@ availsToGlobalRdrEnv mod_name avails -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] - decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, + is_qual = False, + is_dloc = srcLocSpan interactiveSrcLoc } mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl = case lookupUFM hpt (moduleName modl) of - Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ + Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> - case mi_globals (hm_iface details) of - Nothing -> - ghcError (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return env + case mi_globals (hm_iface details) of + Nothing -> + ghcError (ProgramError ("mkTopLevEnv: not interpreted " + ++ showSDoc (ppr modl))) + Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -872,11 +866,11 @@ moduleIsInterpreted modl = withSession $ \h -> _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) --- Filter the instances by the ones whose tycons (or clases resp) +-- Filter the instances by the ones whose tycons (or clases resp) -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. --- (see Trac #1581) -getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) +-- (see Trac #1581) +getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst])) getInfo name = withSession $ \hsc_env -> do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name @@ -886,15 +880,15 @@ getInfo name let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env) return (Just (thing, fixity, filter (plausible rdr_env) ispecs)) where - plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env - = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec - where -- A name is ok if it's in the rdr_env, - -- whether qualified or not - ok n | n == name = True -- The one we looked for in the first place! - | isBuiltInSyntax n = True - | isExternalName n = any ((== n) . gre_name) - (lookupGRE_Name rdr_env n) - | otherwise = True + plausible rdr_env ispec -- Dfun involving only names that are in ic_rn_glb_env + = all ok $ nameSetToList $ orphNamesOfType $ idType $ instanceDFunId ispec + where -- A name is ok if it's in the rdr_env, + -- whether qualified or not + ok n | n == name = True -- The one we looked for in the first place! + | isBuiltInSyntax n = True + | isExternalName n = any ((== n) . gre_name) + (lookupGRE_Name rdr_env n) + | otherwise = True -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] @@ -903,7 +897,7 @@ getNamesInScope = withSession $ \hsc_env -> do getRdrNamesInScope :: GhcMonad m => m [RdrName] getRdrNamesInScope = withSession $ \hsc_env -> do - let + let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv @@ -920,9 +914,9 @@ greToRdrNames GRE{ gre_name = name, gre_prov = prov } occ = nameOccName name unqual = Unqual occ do_spec decl_spec - | is_qual decl_spec = [qual] - | otherwise = [unqual,qual] - where qual = Qual (is_as decl_spec) occ + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. @@ -949,20 +943,18 @@ typeKind normalise str = withSession $ \hsc_env -> do liftIO $ hscKcType hsc_env normalise str ----------------------------------------------------------------------------- --- cmCompileExpr: compile an expression and deliver an HValue +-- Compile an expression, run it and deliver the resulting HValue compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) - -- Run it! - hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) - + hvals <- liftIO hval case (ids,hvals) of ([_],[hv]) -> return hv - _ -> panic "compileExpr" + _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- --- Compile an expression into a dynamic +-- Compile an expression, run it and return the result as a dynamic dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do @@ -979,13 +971,13 @@ dynCompileExpr expr = do } setContext (IIDecl importDecl : iis) let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession $ \hsc_env -> + Just (ids, hvals) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt setContext iis vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of - (_:[], v:[]) -> return v - _ -> panic "dynCompileExpr" + (_:[], v:[]) -> return v + _ -> panic "dynCompileExpr" ----------------------------------------------------------------------------- -- show a module and it's source/object filenames @@ -999,10 +991,10 @@ showModule mod_summary = isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return (not obj_linkable) - where - obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) + Nothing -> panic "missing linkable" + Just mod_info -> return (not obj_linkable) + where + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) ---------------------------------------------------------------------------- -- RTTI primitives @@ -1019,7 +1011,7 @@ obtainTermFromId hsc_env bound force id = do -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - hv <- Linker.getHValue hsc_env (varName id) + hv <- Linker.getHValue hsc_env (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d7dc6bc764..1d6ad4a472 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -59,7 +59,7 @@ import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo.Binary import Distribution.Package hiding (PackageId,depends) import FastString -import ErrUtils ( debugTraceMsg, putMsg, Message ) +import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import Exception import System.Directory @@ -272,7 +272,7 @@ setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs | otherwise = pkgs' hide pkg = pkg{ exposed = False } - distrust pkg = pkg{ exposed = False } + distrust pkg = pkg{ trusted = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig @@ -986,7 +986,7 @@ closeDeps :: PackageConfigMap -> IO [PackageId] closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) -throwErr :: MaybeErr Message a -> IO a +throwErr :: MaybeErr MsgDoc a -> IO a throwErr m = case m of Failed e -> ghcError (CmdLineError (showSDoc e)) Succeeded r -> return r @@ -994,7 +994,7 @@ throwErr m = case m of closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId -> [(PackageId,Maybe PackageId)] - -> MaybeErr Message [PackageId] + -> MaybeErr MsgDoc [PackageId] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper @@ -1002,7 +1002,7 @@ add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) - -> MaybeErr Message [PackageId] + -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 23906c69bc..b46ca17f49 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -192,6 +192,7 @@ initSysTools mbMinusB Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) ; targetArch <- readSetting "target arch" ; targetOS <- readSetting "target os" + ; targetWordSize <- readSetting "target word size" ; targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack" ; targetHasIdentDirective <- readSetting "target has .ident directive" ; targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols" @@ -250,13 +251,14 @@ initSysTools mbMinusB ld_args = gcc_args -- We just assume on command line - ; let lc_prog = "llc" - lo_prog = "opt" + ; lc_prog <- getSetting "LLVM llc command" + ; lo_prog <- getSetting "LLVM opt command" ; return $ Settings { sTargetPlatform = Platform { platformArch = targetArch, platformOS = targetOS, + platformWordSize = targetWordSize, platformHasGnuNonexecStack = targetHasGnuNonexecStack, platformHasIdentDirective = targetHasIdentDirective, platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 830a352be2..34afd5ca0e 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -488,7 +488,7 @@ mustExposeTyCon exports tc exported_con con = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) -tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] +tidyInstances :: (DFunId -> DFunId) -> [ClsInst] -> [ClsInst] tidyInstances tidy_dfun ispecs = map tidy ispecs where @@ -513,6 +513,7 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars tidy_var_v = lookup_var var_v , isExportedId tidy_var , isExportedId tidy_var_v + , isDataConWorkId var || not (isImplicitId var) ] tidy_scalarVars = mkVarSet [ lookup_var var diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 767e3ece82..b818b012c7 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -874,8 +874,8 @@ instance Monad CmmOptM where addImportCmmOpt :: CLabel -> CmmOptM () addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #) -getDynFlagsCmmOpt :: CmmOptM DynFlags -getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) +instance HasDynFlags CmmOptM where + getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of @@ -909,9 +909,9 @@ cmmStmtConFold stmt src' <- cmmExprConFold DataReference src return $ CmmStore addr' src' - CmmJump addr regs + CmmJump addr live -> do addr' <- cmmExprConFold JumpReference addr - return $ CmmJump addr' regs + return $ CmmJump addr' live CmmCall target regs args returns -> do target' <- case target of @@ -926,7 +926,7 @@ cmmStmtConFold stmt CmmCondBranch test dest -> do test' <- cmmExprConFold DataReference test - dflags <- getDynFlagsCmmOpt + dflags <- getDynFlags let platform = targetPlatform dflags return $ case test' of CmmLit (CmmInt 0 _) -> @@ -945,7 +945,7 @@ cmmStmtConFold stmt cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = do - dflags <- getDynFlagsCmmOpt + dflags <- getDynFlags -- Skip constant folding if new code generator is running -- (this optimization is done in Hoopl) let expr' = if dopt Opt_TryNewCodeGen dflags @@ -963,7 +963,7 @@ cmmExprCon _ other = other -- of things to do. cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprNative referenceKind expr = do - dflags <- getDynFlagsCmmOpt + dflags <- getDynFlags let platform = targetPlatform dflags arch = platformArch platform case expr of diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 71250a2452..eb59d2b82a 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -29,7 +29,7 @@ module NCGMonad ( getNewRegPairNat, getPicBaseMaybeNat, getPicBaseNat, - getDynFlagsNat + getDynFlags ) where @@ -100,11 +100,9 @@ getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) -> case takeUniqFromSupply us of (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags)) - -getDynFlagsNat :: NatM DynFlags -getDynFlagsNat - = NatM $ \ (NatM_State us delta imports pic dflags) -> - (dflags, (NatM_State us delta imports pic dflags)) +instance HasDynFlags NatM where + getDynFlags = NatM $ \ (NatM_State us delta imports pic dflags) -> + (dflags, (NatM_State us delta imports pic dflags)) getDeltaNat :: NatM Int @@ -139,14 +137,14 @@ getNewLabelNat getNewRegNat :: Size -> NatM Reg getNewRegNat rep = do u <- getUniqueNat - dflags <- getDynFlagsNat + dflags <- getDynFlags return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) getNewRegPairNat rep = do u <- getUniqueNat - dflags <- getDynFlagsNat + dflags <- getDynFlags let vLo = targetMkVirtualReg (targetPlatform dflags) u rep let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep let hi = RegVirtual $ getHiVirtualRegFromLo vLo diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index a043af01f8..7b704cbe8f 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -73,7 +73,7 @@ cmmTopCodeGen cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlagsNat + dflags <- getDynFlags let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags @@ -114,7 +114,7 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = do - dflags <- getDynFlagsNat + dflags <- getDynFlags case stmt of CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) @@ -142,7 +142,7 @@ stmtToInstrs stmt = do CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids CmmJump arg _ -> genJump arg - CmmReturn _ -> + CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" @@ -357,13 +357,13 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi) rlo iselExpr64 expr - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags pprPanic "iselExpr64(powerpc)" (pprPlatform (targetPlatform dflags) expr) getRegister :: CmmExpr -> NatM Register -getRegister e = do dflags <- getDynFlagsNat +getRegister e = do dflags <- getDynFlags getRegister' dflags e getRegister' :: DynFlags -> CmmExpr -> NatM Register @@ -555,7 +555,7 @@ getRegister' _ (CmmLit (CmmInt i rep)) getRegister' _ (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let size = floatSize frep @@ -845,16 +845,11 @@ genCCall :: CmmCallTarget -- function to call -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall target dest_regs argsAndHints - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags case platformOS (targetPlatform dflags) of OSLinux -> genCCall' GCPLinux target dest_regs argsAndHints OSDarwin -> genCCall' GCPDarwin target dest_regs argsAndHints - OSSolaris2 -> panic "PPC.CodeGen.genCCall: not defined for this os" - OSMinGW32 -> panic "PPC.CodeGen.genCCall: not defined for this os" - OSFreeBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" - OSOpenBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" - OSNetBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" - OSUnknown -> panic "PPC.CodeGen.genCCall: not defined for this os" + _ -> panic "PPC.CodeGen.genCCall: not defined for this os" data GenCCallPlatform = GCPLinux | GCPDarwin @@ -1098,7 +1093,7 @@ genCCall' gcp target dest_regs argsAndHints outOfLineMachOp mop = do - dflags <- getDynFlagsNat + dflags <- getDynFlags mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction let mopLabelOrExpr = case mopExpr of @@ -1162,7 +1157,7 @@ genSwitch expr ids (reg,e_code) <- getSomeReg expr tmp <- getNewRegNat II32 lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let code = e_code `appOL` t_code `appOL` toOL [ @@ -1364,7 +1359,7 @@ coerceInt2FP fromRep toRep x = do lbl <- getNewLabelNat itmp <- getNewRegNat II32 ftmp <- getNewRegNat FF64 - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 663b95b236..4c295f11d5 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -63,7 +63,7 @@ cmmTopCodeGen :: RawCmmDecl cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do - dflags <- getDynFlagsNat + dflags <- getDynFlags let platform = targetPlatform dflags (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks @@ -143,7 +143,7 @@ stmtToInstrs stmt = case stmt of CmmSwitch arg ids -> genSwitch arg ids CmmJump arg _ -> genJump arg - CmmReturn _ + CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 48c766f8e0..91351a2e18 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -141,7 +141,7 @@ genCCall target dest_regs argsAndHints let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) - dflags <- getDynFlagsNat + dflags <- getDynFlags return $ argcode `appOL` move_sp_down `appOL` @@ -276,7 +276,7 @@ outOfLineMachOp mop = do let functionName = outOfLineMachOp_table mop - dflags <- getDynFlagsNat + dflags <- getDynFlags mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 215a565ba6..f02b7a45a8 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -62,10 +62,10 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> do dflags <- getDynFlagsNat + _ -> do dflags <- getDynFlags pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlagsNat +getCondCode other = do dflags <- getDynFlags pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pprPlatform (targetPlatform dflags) other) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot index 0e639a3caf..7de92cb659 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -1,14 +1,7 @@ -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister + getSomeReg, + getRegister ) where diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 5bcab2cb10..5352281296 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -190,7 +190,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - dflags <- getDynFlagsNat + dflags <- getDynFlags let platform = targetPlatform dflags code = a_code `appOL` toOL @@ -201,7 +201,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) iselExpr64 expr - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags pprPanic "iselExpr64(sparc)" (pprPlatform (targetPlatform dflags) expr) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 5f0f716281..c68519522d 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -63,12 +63,12 @@ import Data.Word is32BitPlatform :: NatM Bool is32BitPlatform = do - dflags <- getDynFlagsNat + dflags <- getDynFlags return $ target32Bit (targetPlatform dflags) sse2Enabled :: NatM Bool sse2Enabled = do - dflags <- getDynFlagsNat + dflags <- getDynFlags case platformArch (targetPlatform dflags) of ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be -- possible to make it optional, but we'd need to @@ -81,7 +81,7 @@ sse2Enabled = do sse4_2Enabled :: NatM Bool sse4_2Enabled = do - dflags <- getDynFlagsNat + dflags <- getDynFlags return (dopt Opt_SSE4_2 dflags) if_sse2 :: NatM a -> NatM a -> NatM a @@ -96,7 +96,7 @@ cmmTopCodeGen cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlagsNat + dflags <- getDynFlags let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags @@ -167,7 +167,7 @@ stmtToInstrs stmt = do CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids CmmJump arg _ -> genJump arg - CmmReturn _ -> + CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" @@ -400,7 +400,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do ) iselExpr64 expr - = do dflags <- getDynFlagsNat + = do dflags <- getDynFlags pprPanic "iselExpr64(i386)" (pprPlatform (targetPlatform dflags) expr) @@ -887,7 +887,7 @@ getRegister' _ (CmmLit lit) in return (Any size code) -getRegister' _ other = do dflags <- getDynFlagsNat +getRegister' _ other = do dflags <- getDynFlags pprPanic "getRegister(x86)" (pprPlatform (targetPlatform dflags) other) @@ -1131,7 +1131,7 @@ isOperand _ _ = False memConstant :: Int -> CmmLit -> NatM Amode memConstant align lit = do lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags (addr, addr_code) <- if target32Bit (targetPlatform dflags) then do dynRef <- cmmMakeDynamicReference dflags @@ -1228,10 +1228,10 @@ getCondCode (CmmMachOp mop [x, y]) MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _other -> do dflags <- getDynFlagsNat + _other -> do dflags <- getDynFlags pprPanic "getCondCode(x86,x86_64,sparc)" (pprPlatform (targetPlatform dflags) (CmmMachOp mop [x,y])) -getCondCode other = do dflags <- getDynFlagsNat +getCondCode other = do dflags <- getDynFlags pprPanic "getCondCode(2)(x86,sparc)" (pprPlatform (targetPlatform dflags) other) @@ -1621,7 +1621,7 @@ genCCall is32Bit (CmmPrim (MO_PopCnt width)) dest_regs@[CmmHinted dst _] unitOL (POPCNT size (OpReg src_r) (getRegisterReg False (CmmLocal dst)))) else do - dflags <- getDynFlagsNat + dflags <- getDynFlags targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv @@ -1690,6 +1690,7 @@ genCCall32 target dest_regs args = use_sse2 <- sse2Enabled push_codes <- mapM (push_arg use_sse2) (reverse args) delta <- getDeltaNat + MASSERT (delta == delta0 - tot_arg_size) -- in -- deal with static vs dynamic call targets @@ -1728,10 +1729,10 @@ genCCall32 target dest_regs args = (if pop_size==0 then [] else [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) ++ - [DELTA (delta + tot_arg_size)] + [DELTA delta0] ) -- in - setDeltaNat (delta + tot_arg_size) + setDeltaNat delta0 let -- assign the results, if necessary @@ -1744,9 +1745,11 @@ genCCall32 target dest_regs args = (ImmInt 0) sz = floatSize w in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA (delta0 - b), GST sz fake0 tmp_amode, MOV sz (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp)] + ADD II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA delta0] else unitOL (GMOV fake0 r_dest) | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), MOV II32 (OpReg edx) (OpReg r_dest_hi)] @@ -1959,7 +1962,7 @@ genCCall64 target dest_regs args = (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat setDeltaNat (delta-arg_size) - dflags <- getDynFlagsNat + dflags <- getDynFlags let platform = targetPlatform dflags code' = code `appOL` arg_code `appOL` toOL [ SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , @@ -1992,7 +1995,7 @@ maxInlineSizeThreshold = 128 outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock outOfLineCmmOp mop res args = do - dflags <- getDynFlagsNat + dflags <- getDynFlags targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv @@ -2063,7 +2066,7 @@ genSwitch expr ids = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - dflags <- getDynFlagsNat + dflags <- getDynFlags dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) diff --git a/compiler/parser/LexCore.hs b/compiler/parser/LexCore.hs index b3d8d63fbd..861fffb7f6 100644 --- a/compiler/parser/LexCore.hs +++ b/compiler/parser/LexCore.hs @@ -1,11 +1,3 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module LexCore where import ParserCoreUtils @@ -15,39 +7,39 @@ import Numeric isNameChar :: Char -> Bool isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'') - || (c == '$') || (c == '-') || (c == '.') + || (c == '$') || (c == '-') || (c == '.') isKeywordChar :: Char -> Bool -isKeywordChar c = isAlpha c || (c == '_') +isKeywordChar c = isAlpha c || (c == '_') -lexer :: (Token -> P a) -> P a -lexer cont [] = cont TKEOF [] -lexer cont ('\n':cs) = \line -> lexer cont cs (line+1) +lexer :: (Token -> P a) -> P a +lexer cont [] = cont TKEOF [] +lexer cont ('\n':cs) = \line -> lexer cont cs (line+1) lexer cont ('-':'>':cs) = cont TKrarrow cs -lexer cont (c:cs) - | isSpace c = lexer cont cs +lexer cont (c:cs) + | isSpace c = lexer cont cs | isLower c || (c == '_') = lexName cont TKname (c:cs) - | isUpper c = lexName cont TKcname (c:cs) + | isUpper c = lexName cont TKcname (c:cs) | isDigit c || (c == '-') = lexNum cont (c:cs) -lexer cont ('%':cs) = lexKeyword cont cs -lexer cont ('\'':cs) = lexChar cont cs -lexer cont ('\"':cs) = lexString [] cont cs -lexer cont ('#':cs) = cont TKhash cs -lexer cont ('(':cs) = cont TKoparen cs -lexer cont (')':cs) = cont TKcparen cs -lexer cont ('{':cs) = cont TKobrace cs -lexer cont ('}':cs) = cont TKcbrace cs +lexer cont ('%':cs) = lexKeyword cont cs +lexer cont ('\'':cs) = lexChar cont cs +lexer cont ('\"':cs) = lexString [] cont cs +lexer cont ('#':cs) = cont TKhash cs +lexer cont ('(':cs) = cont TKoparen cs +lexer cont (')':cs) = cont TKcparen cs +lexer cont ('{':cs) = cont TKobrace cs +lexer cont ('}':cs) = cont TKcbrace cs lexer cont ('=':cs) = cont TKeq cs lexer cont (':':'=':':':cs) = cont TKcoloneqcolon cs lexer cont (':':':':cs) = cont TKcoloncolon cs -lexer cont ('*':cs) = cont TKstar cs -lexer cont ('.':cs) = cont TKdot cs +lexer cont ('*':cs) = cont TKstar cs +lexer cont ('.':cs) = cont TKdot cs lexer cont ('\\':cs) = cont TKlambda cs -lexer cont ('@':cs) = cont TKat cs -lexer cont ('?':cs) = cont TKquestion cs -lexer cont (';':cs) = cont TKsemicolon cs +lexer cont ('@':cs) = cont TKat cs +lexer cont ('?':cs) = cont TKquestion cs +lexer cont (';':cs) = cont TKsemicolon cs -- 20060420 GHC spits out constructors with colon in them nowadays. jds -- 20061103 but it's easier to parse if we split on the colon, and treat them -- as several tokens @@ -68,7 +60,7 @@ lexChar _ cs = panic ("lexChar: " ++ show cs) lexString :: String -> (Token -> [Char] -> Int -> ParseResult a) -> String -> Int -> ParseResult a -lexString s cont ('\\':'x':h1:h0:cs) +lexString s cont ('\\':'x':h1:h0:cs) | isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs lexString _ _ ('\\':_) = failP "invalid string character" ['\\'] lexString _ _ ('\'':_) = failP "invalid string character" ['\''] @@ -86,14 +78,14 @@ lexNum :: (Token -> String -> a) -> String -> a lexNum cont cs = case cs of ('-':cs) -> f (-1) cs - _ -> f 1 cs - where f sgn cs = + _ -> f 1 cs + where f sgn cs = case span isDigit cs of - (digits,'.':c:rest) - | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' - where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) - -- When reading a floating-point number, which is - -- a bit complicated, use the standard library function + (digits,'.':c:rest) + | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' + where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) + -- When reading a floating-point number, which is + -- a bit complicated, use the standard library function -- "readFloat" (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest @@ -103,21 +95,21 @@ lexName cont cstr cs = cont (cstr name) rest lexKeyword :: (Token -> [Char] -> Int -> ParseResult a) -> String -> Int -> ParseResult a -lexKeyword cont cs = +lexKeyword cont cs = case span isKeywordChar cs of ("module",rest) -> cont TKmodule rest ("data",rest) -> cont TKdata rest ("newtype",rest) -> cont TKnewtype rest - ("forall",rest) -> cont TKforall rest - ("rec",rest) -> cont TKrec rest - ("let",rest) -> cont TKlet rest - ("in",rest) -> cont TKin rest - ("case",rest) -> cont TKcase rest - ("of",rest) -> cont TKof rest - ("cast",rest) -> cont TKcast rest - ("note",rest) -> cont TKnote rest + ("forall",rest) -> cont TKforall rest + ("rec",rest) -> cont TKrec rest + ("let",rest) -> cont TKlet rest + ("in",rest) -> cont TKin rest + ("case",rest) -> cont TKcase rest + ("of",rest) -> cont TKof rest + ("cast",rest) -> cont TKcast rest + ("note",rest) -> cont TKnote rest ("external",rest) -> cont TKexternal rest ("local",rest) -> cont TKlocal rest ("_",rest) -> cont TKwild rest - _ -> failP "invalid keyword" ('%':cs) + _ -> failP "invalid keyword" ('%':cs) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index f235465758..6e74cfbc4a 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -145,7 +145,7 @@ haskell :- -- everywhere: skip whitespace and comments $white_no_nl+ ; -$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } +$tab+ { warn Opt_WarnTabs (text "Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out -- pragmas, "{-#", so that we don't accidentally treat them as comments. @@ -509,8 +509,6 @@ data Token | ITocurly -- special symbols | ITccurly - | ITocurlybar -- {|, for type applications - | ITccurlybar -- |}, for type applications | ITvocurly | ITvccurly | ITobrack @@ -1484,7 +1482,7 @@ data ParseResult a SrcSpan -- The start and end of the text span related to -- the error. Might be used in environments which can -- show this span, e.g. by highlighting it. - Message -- The error message + MsgDoc -- The error message data PState = PState { buffer :: StringBuffer, @@ -1562,8 +1560,8 @@ failSpanMsgP span msg = P $ \_ -> PFailed span msg getPState :: P PState getPState = P $ \s -> POk s s -getDynFlags :: P DynFlags -getDynFlags = P $ \s -> POk s (dflags s) +instance HasDynFlags P where + getDynFlags = P $ \s -> POk s (dflags s) withThisPackage :: (PackageId -> a) -> P a withThisPackage f @@ -1959,7 +1957,7 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} -> srcParseErr :: StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token - -> Message + -> MsgDoc srcParseErr buf len = hcat [ if null token then ptext (sLit "parse error (possibly incorrect indentation)") diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 855a428798..c05f2e1e6b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -35,7 +35,7 @@ import RdrName import TcEvidence ( emptyTcEvBinds ) import TysPrim ( liftedTypeKindTyConName, eqPrimTyCon ) import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, - unboxedSingletonTyCon, unboxedSingletonDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, @@ -294,8 +294,6 @@ incorrect. '{' { L _ ITocurly } -- special symbols '}' { L _ ITccurly } - '{|' { L _ ITocurlybar } - '|}' { L _ ITccurlybar } vocurly { L _ ITvocurly } -- virtual open curly (from layout) vccurly { L _ ITvccurly } -- virtual close curly (from layout) '[' { L _ ITobrack } @@ -569,10 +567,7 @@ topdecls :: { OrdList (LHsDecl RdrName) } topdecl :: { OrdList (LHsDecl RdrName) } : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } - | 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in - unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} + | inst_decl { unitOL (L1 (InstD (unLoc $1))) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } @@ -631,12 +626,6 @@ ty_decl :: { LTyClDecl RdrName } -- infix type constructors to be declared {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) } - -- type instance declarations - | 'type' 'instance' type '=' ctype - -- Note the use of type for the head; this allows - -- infix type constructors and type patterns - {% mkTySynonym (comb2 $1 $5) True $3 $5 } - -- ordinary data type or newtype declaration | data_or_newtype tycl_hdr constrs deriving {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 @@ -657,18 +646,32 @@ ty_decl :: { LTyClDecl RdrName } | 'data' 'family' type opt_kind_sig {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } +inst_decl :: { LInstDecl RdrName } + : 'instance' inst_type where_inst + { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) + in L (comb3 $1 $2 $3) (ClsInstDecl $2 binds sigs ats) } + + -- type instance declarations + | 'type' 'instance' type '=' ctype + -- Note the use of type for the head; this allows + -- infix type constructors and type patterns + {% do { L loc d <- mkTySynonym (comb2 $1 $5) True $3 $5 + ; return (L loc (FamInstDecl d)) } } + -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 - Nothing (reverse (unLoc $4)) (unLoc $5) } + {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 + Nothing (reverse (unLoc $4)) (unLoc $5) + ; return (L loc (FamInstDecl d)) } } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 - (unLoc $4) (unLoc $5) (unLoc $6) } - + {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + (unLoc $4) (unLoc $5) (unLoc $6) + ; return (L loc (FamInstDecl d)) } } + -- Associated type family declarations -- -- * They have a different syntax than on the toplevel (no family special @@ -1047,20 +1050,22 @@ btype :: { LHsType RdrName } | atype { $1 } atype :: { LHsType RdrName } - : gtycon { L1 (HsTyVar (unLoc $1)) } - | tyvar { L1 (HsTyVar (unLoc $1)) } - | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only - | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only - | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) } - | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } - | '[' ctype ']' { LL $ HsListTy $2 } - | '[:' ctype ':]' { LL $ HsPArrTy $2 } - | '(' ctype ')' { LL $ HsParTy $2 } - | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } - | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } - | '$(' exp ')' { LL $ mkHsSpliceTy $2 } - | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ - mkUnqual varName (getTH_ID_SPLICE $1) } + : ntgtycon { L1 (HsTyVar (unLoc $1)) } -- Not including unit tuples + | tyvar { L1 (HsTyVar (unLoc $1)) } -- (See Note [Unit tuples]) + | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only + | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only + | '(' ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple [] } + | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) } + | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] } + | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } + | '[' ctype ']' { LL $ HsListTy $2 } + | '[:' ctype ':]' { LL $ HsPArrTy $2 } + | '(' ctype ')' { LL $ HsParTy $2 } + | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } + | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } + | '$(' exp ')' { LL $ mkHsSpliceTy $2 } + | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE $1) } -- see Note [Promotion] for the followings | SIMPLEQUOTE qconid { LL $ HsTyVar $ unLoc $2 } | SIMPLEQUOTE '(' ')' { LL $ HsTyVar $ getRdrName unitDataCon } @@ -1425,14 +1430,6 @@ aexp1 :: { LHsExpr RdrName } ; checkRecordSyntax (LL r) }} | aexp2 { $1 } --- Here was the syntax for type applications that I was planning --- but there are difficulties (e.g. what order for type args) --- so it's not enabled yet. --- But this case *is* used for the left hand side of a generic definition, --- which is parsed as an expression before being munged into a pattern - | qcname '{|' type '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1))) - (sL (getLoc $3) (HsType $3)) } - aexp2 :: { LHsExpr RdrName } : ipvar { L1 (HsIPVar $! unLoc $1) } | qcname { L1 (HsVar $! unLoc $1) } @@ -1584,16 +1581,17 @@ squals :: { Located [LStmt RdrName] } -- In reverse order, because the last -- | '{|' pquals '|}' { L1 [$2] } --- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |} --- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user --- demand. +-- It is possible to enable bracketing (associating) qualifier lists +-- by uncommenting the lines with {| |} above. Due to a lack of +-- consensus on the syntax, this feature is not being used until we +-- get user demand. transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } -- Function is applied to a list of stmts *in order* - : 'then' exp { LL $ \leftStmts -> (mkTransformStmt leftStmts $2) } - | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt leftStmts $2 $4) } - | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt leftStmts $4) } - | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt leftStmts $4 $6) } + : 'then' exp { LL $ \ss -> (mkTransformStmt ss $2) } + | 'then' exp 'by' exp { LL $ \ss -> (mkTransformByStmt ss $2 $4) } + | 'then' 'group' 'using' exp { LL $ \ss -> (mkGroupUsingStmt ss $4) } + | 'then' 'group' 'by' exp 'using' exp { LL $ \ss -> (mkGroupByUsingStmt ss $4 $6) } -- Note that 'group' is a special_id, which means that you can enable -- TransformListComp while still using Data.List.group. However, this @@ -1779,7 +1777,7 @@ con_list : con { L1 [$1] } sysdcon :: { Located DataCon } -- Wired in data constructors : '(' ')' { LL unitDataCon } | '(' commas ')' { LL $ tupleCon BoxedTuple ($2 + 1) } - | '(#' '#)' { LL $ unboxedSingletonDataCon } + | '(#' '#)' { LL $ unboxedUnitDataCon } | '(#' commas '#)' { LL $ tupleCon UnboxedTuple ($2 + 1) } | '[' ']' { LL nilDataCon } @@ -1791,24 +1789,31 @@ qconop :: { Located RdrName } : qconsym { $1 } | '`' qconid '`' { LL (unLoc $2) } ------------------------------------------------------------------------------ +---------------------------------------------------------------------------- -- Type constructors -gtycon :: { Located RdrName } -- A "general" qualified tycon - : oqtycon { $1 } + +-- See Note [Unit tuples] in HsTypes for the distinction +-- between gtycon and ntgtycon +gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples + : ntgtycon { $1 } | '(' ')' { LL $ getRdrName unitTyCon } + | '(#' '#)' { LL $ getRdrName unboxedUnitTyCon } + +ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples + : oqtycon { $1 } | '(' commas ')' { LL $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) } - | '(#' '#)' { LL $ getRdrName unboxedSingletonTyCon } | '(#' commas '#)' { LL $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) } | '(' '->' ')' { LL $ getRdrName funTyCon } | '[' ']' { LL $ listTyCon_RDR } | '[:' ':]' { LL $ parrTyCon_RDR } | '(' '~#' ')' { LL $ getRdrName eqPrimTyCon } -oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon +oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; + -- These can appear in export lists : qtycon { $1 } | '(' qtyconsym ')' { LL (unLoc $2) } - | '(' '~' ')' { LL $ eqTyCon_RDR } -- In here rather than gtycon because I want to write it in the GHC.Types export list + | '(' '~' ')' { LL $ eqTyCon_RDR } qtyconop :: { Located RdrName } -- Qualified or unqualified : qtyconsym { $1 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 10e731b3e0..14778171f5 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -56,7 +56,7 @@ import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import TcEvidence ( idHsWrapper ) import Lexer -import TysWiredIn ( unitTyCon ) +import TysWiredIn ( unitTyCon, unitDataCon ) import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) @@ -360,10 +360,12 @@ splitCon :: LHsType RdrName splitCon ty = split ty [] where - split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) - split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty) + split (L _ (HsAppTy t u)) ts = split t (u : ts) + split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) + split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon []) + -- See Note [Unit tuples] in HsTypes + split (L l _) _ = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty) mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts @@ -535,12 +537,13 @@ checkTyClHdr ty goL (L l ty) acc = go l ty acc go l (HsTyVar tc) acc - | isRdrTc tc = return (L l tc, acc) - + | isRdrTc tc = return (L l tc, acc) go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc | isRdrTc tc = return (ltc, t1:t2:acc) go _ (HsParTy ty) acc = goL ty acc go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc) + go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), []) + -- See Note [Unit tuples] in HsTypes go l _ _ = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty) -- Check that associated type declarations of a class are all kind signatures. @@ -560,14 +563,11 @@ checkContext (L l orig_t) = check orig_t where check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = return (L l ts) + = return (L l ts) -- Ditto () check (HsParTy ty) -- to be sure HsParTy doesn't get into the way = check (unLoc ty) - check (HsTyVar t) -- Empty context shows up as a unit type () - | t == getRdrName unitTyCon = return (L l []) - check _ = return (L l [L l orig_t]) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index f95b21dae2..e6eb83bea8 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -253,12 +253,16 @@ basicKnownKeyNames -- Integer integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, @@ -820,17 +824,23 @@ minusName = methName gHC_NUM (fsLit "-") minusClassOpKey negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName :: Name integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey +integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey +integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey @@ -849,6 +859,12 @@ geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geI compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey +quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey +remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey +floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey +doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey +encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey +encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey @@ -1437,11 +1453,15 @@ assertIdKey = mkPreludeMiscIdUnique 44 runSTRepIdKey = mkPreludeMiscIdUnique 45 mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey, + integerToWord64IdKey, integerToInt64IdKey, plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, negateIntegerIdKey, eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey, leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey, compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, + quotIntegerIdKey, remIntegerIdKey, + floatFromIntegerIdKey, doubleFromIntegerIdKey, + encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, gcdIntegerIdKey, lcmIntegerIdKey, andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique @@ -1449,29 +1469,37 @@ mkIntegerIdKey = mkPreludeMiscIdUnique 60 smallIntegerIdKey = mkPreludeMiscIdUnique 61 integerToWordIdKey = mkPreludeMiscIdUnique 62 integerToIntIdKey = mkPreludeMiscIdUnique 63 -plusIntegerIdKey = mkPreludeMiscIdUnique 64 -timesIntegerIdKey = mkPreludeMiscIdUnique 65 -minusIntegerIdKey = mkPreludeMiscIdUnique 66 -negateIntegerIdKey = mkPreludeMiscIdUnique 67 -eqIntegerIdKey = mkPreludeMiscIdUnique 68 -neqIntegerIdKey = mkPreludeMiscIdUnique 69 -absIntegerIdKey = mkPreludeMiscIdUnique 70 -signumIntegerIdKey = mkPreludeMiscIdUnique 71 -leIntegerIdKey = mkPreludeMiscIdUnique 72 -gtIntegerIdKey = mkPreludeMiscIdUnique 73 -ltIntegerIdKey = mkPreludeMiscIdUnique 74 -geIntegerIdKey = mkPreludeMiscIdUnique 75 -compareIntegerIdKey = mkPreludeMiscIdUnique 76 -quotRemIntegerIdKey = mkPreludeMiscIdUnique 77 -divModIntegerIdKey = mkPreludeMiscIdUnique 78 -gcdIntegerIdKey = mkPreludeMiscIdUnique 79 -lcmIntegerIdKey = mkPreludeMiscIdUnique 80 -andIntegerIdKey = mkPreludeMiscIdUnique 81 -orIntegerIdKey = mkPreludeMiscIdUnique 82 -xorIntegerIdKey = mkPreludeMiscIdUnique 83 -complementIntegerIdKey = mkPreludeMiscIdUnique 84 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 85 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 86 +integerToWord64IdKey = mkPreludeMiscIdUnique 64 +integerToInt64IdKey = mkPreludeMiscIdUnique 65 +plusIntegerIdKey = mkPreludeMiscIdUnique 66 +timesIntegerIdKey = mkPreludeMiscIdUnique 67 +minusIntegerIdKey = mkPreludeMiscIdUnique 68 +negateIntegerIdKey = mkPreludeMiscIdUnique 69 +eqIntegerIdKey = mkPreludeMiscIdUnique 70 +neqIntegerIdKey = mkPreludeMiscIdUnique 71 +absIntegerIdKey = mkPreludeMiscIdUnique 72 +signumIntegerIdKey = mkPreludeMiscIdUnique 73 +leIntegerIdKey = mkPreludeMiscIdUnique 74 +gtIntegerIdKey = mkPreludeMiscIdUnique 75 +ltIntegerIdKey = mkPreludeMiscIdUnique 76 +geIntegerIdKey = mkPreludeMiscIdUnique 77 +compareIntegerIdKey = mkPreludeMiscIdUnique 78 +quotRemIntegerIdKey = mkPreludeMiscIdUnique 79 +divModIntegerIdKey = mkPreludeMiscIdUnique 80 +quotIntegerIdKey = mkPreludeMiscIdUnique 81 +remIntegerIdKey = mkPreludeMiscIdUnique 82 +floatFromIntegerIdKey = mkPreludeMiscIdUnique 83 +doubleFromIntegerIdKey = mkPreludeMiscIdUnique 84 +encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 85 +encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 86 +gcdIntegerIdKey = mkPreludeMiscIdUnique 87 +lcmIntegerIdKey = mkPreludeMiscIdUnique 88 +andIntegerIdKey = mkPreludeMiscIdUnique 89 +orIntegerIdKey = mkPreludeMiscIdUnique 90 +xorIntegerIdKey = mkPreludeMiscIdUnique 91 +complementIntegerIdKey = mkPreludeMiscIdUnique 92 +shiftLIntegerIdKey = mkPreludeMiscIdUnique 93 +shiftRIntegerIdKey = mkPreludeMiscIdUnique 94 rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 100 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 40ee5b0850..fc0c20ad48 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -621,31 +621,44 @@ builtinRules builtinIntegerRules :: [CoreRule] builtinIntegerRules = - [rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_binop "plusInteger" plusIntegerName (+), - rule_binop "timesInteger" timesIntegerName (*), - rule_binop "minusInteger" minusIntegerName (-), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Bool "eqInteger" eqIntegerName (==), - rule_binop_Bool "neqInteger" neqIntegerName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Bool "leInteger" leIntegerName (<=), - rule_binop_Bool "gtInteger" gtIntegerName (>), - rule_binop_Bool "ltInteger" ltIntegerName (<), - rule_binop_Bool "geInteger" geIntegerName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_divop "quotRemInteger" quotRemIntegerName quotRem, - rule_divop "divModInteger" divModIntegerName divMod, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, - rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] + [-- TODO: smallInteger rule + -- TODO: wordToInteger rule + rule_convert "integerToWord" integerToWordName mkWordLitWord, + rule_convert "integerToInt" integerToIntName mkIntLitInt, + rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64, + -- TODO: word64ToInteger rule + rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64, + -- TODO: int64ToInteger rule + rule_binop "plusInteger" plusIntegerName (+), + rule_binop "minusInteger" minusIntegerName (-), + rule_binop "timesInteger" timesIntegerName (*), + rule_unop "negateInteger" negateIntegerName negate, + rule_binop_Bool "eqInteger" eqIntegerName (==), + rule_binop_Bool "neqInteger" neqIntegerName (/=), + rule_unop "absInteger" absIntegerName abs, + rule_unop "signumInteger" signumIntegerName signum, + rule_binop_Bool "leInteger" leIntegerName (<=), + rule_binop_Bool "gtInteger" gtIntegerName (>), + rule_binop_Bool "ltInteger" ltIntegerName (<), + rule_binop_Bool "geInteger" geIntegerName (>=), + rule_binop_Ordering "compareInteger" compareIntegerName compare, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, + rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, + -- TODO: decodeDoubleInteger rule + rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, + rule_binop "gcdInteger" gcdIntegerName gcd, + rule_binop "lcmInteger" lcmIntegerName lcm, + rule_binop "andInteger" andIntegerName (.&.), + rule_binop "orInteger" orIntegerName (.|.), + rule_binop "xorInteger" xorIntegerName xor, + rule_unop "complementInteger" complementIntegerName complement, + rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, + rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] where rule_convert str name convert = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_convert convert } @@ -655,9 +668,12 @@ builtinIntegerRules = rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop op } - rule_divop str name op + rule_divop_both str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop op } + ru_try = match_Integer_divop_both op } + rule_divop_one str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_one op } rule_Int_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_binop op } @@ -667,6 +683,9 @@ builtinIntegerRules = rule_binop_Ordering str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop_Ordering op } + rule_encodeFloat str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_encodeFloat op } --------------------------------------------------- -- The rule is this: @@ -737,7 +756,7 @@ match_Integer_convert :: Num a -> Maybe (Expr CoreBndr) match_Integer_convert convert id_unf [xl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert (fromIntegral x)) + = Just (convert (fromInteger x)) match_Integer_convert _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) @@ -760,11 +779,11 @@ match_Integer_binop binop id_unf [xl,yl] match_Integer_binop _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions -match_Integer_divop :: (Integer -> Integer -> (Integer, Integer)) - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_divop divop id_unf [xl,yl] +match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_divop_both divop id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 @@ -776,9 +795,20 @@ match_Integer_divop divop id_unf [xl,yl] Type integerTy, Lit (LitInteger r i), Lit (LitInteger s i)] - _ -> panic "match_Integer_divop: mkIntegerId has the wrong type" + _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type" +match_Integer_divop_both _ _ _ = Nothing -match_Integer_divop _ _ _ = Nothing +-- This helper is used for the quotRem and divMod functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_divop_one divop id_unf [xl,yl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (Lit (LitInteger (x `divop` y) i)) +match_Integer_divop_one _ _ _ = Nothing match_Integer_Int_binop :: (Integer -> Int -> Integer) -> IdUnfoldingFun @@ -812,4 +842,15 @@ match_Integer_binop_Ordering binop id_unf [xl, yl] EQ -> eqVal GT -> gtVal match_Integer_binop_Ordering _ _ _ = Nothing + +match_Integer_Int_encodeFloat :: RealFloat a + => (a -> Expr CoreBndr) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_Int_encodeFloat mkLit id_unf [xl,yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl + = Just (mkLit $ encodeFloat x (fromInteger y)) +match_Integer_Int_encodeFloat _ _ _ = Nothing \end{code} diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index d57d1f926e..39bee1fb9d 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -12,7 +12,8 @@ module PrimOp ( tagToEnumKey, primOpOutOfLine, primOpCodeSize, - primOpOkForSpeculation, primOpIsCheap, + primOpOkForSpeculation, primOpOkForSideEffects, + primOpIsCheap, getPrimOpResultInfo, PrimOpResultInfo(..), @@ -307,77 +308,93 @@ primOpOutOfLine :: PrimOp -> Bool Note [PrimOp can_fail and has_side_effects] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - * A primop that is neither can_fail nor has_side_effects can be - executed speculatively, any number of times +Both can_fail and has_side_effects mean that the primop has +some effect that is not captured entirely by its result value. + + ---------- has_side_effects --------------------- + Has some imperative side effect, perhaps on the world (I/O), + or perhaps on some mutable data structure (writeIORef). + Generally speaking all such primops have a type like + State -> input -> (State, output) + so the state token guarantees ordering, and also ensures + that the primop is executed even if 'output' is discarded. + + ---------- can_fail ---------------------------- + Can fail with a seg-fault or divide-by-zero error on some elements + of its input domain. Main examples: + division (fails on zero demoninator + array indexing (fails if the index is out of bounds) + However (ASSUMPTION), these can_fail primops are ALWAYS surrounded + with a test that checks for the bad cases. + +Consequences: + +* You can discard a can_fail primop, or float it _inwards_. + But you cannot float it _outwards_, lest you escape the + dynamic scope of the test. Example: + case d ># 0# of + True -> case x /# d of r -> r +# 1 + False -> 0 + Here we must not float the case outwards to give + case x/# d of r -> + case d ># 0# of + True -> r +# 1 + False -> 0 + +* I believe that exactly the same rules apply to a has_side_effects + primop; you can discard it (remember, the state token will keep + it alive if necessary), or float it in, but not float it out. + + Example of the latter + if blah then let! s1 = writeMutVar s0 v True in s1 + else s0 + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to + let! s1 = writeMutVar s0 v True + in if blah then s1 else s0 + the writeMutVar will be performed in both branches, which is + utterly wrong. + +* You cannot duplicate a has_side_effect primop. You might wonder + how this can occur given the state token threading, but just look + at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like + this + p = case readMutVar# s v of + (# s', r #) -> (S# s', r) + s' = case p of (s', r) -> s' + r = case p of (s', r) -> r + + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. Trac #3207 is real example of this happening. + + However, it's fine to duplicate a can_fail primop. That is + the difference between can_fail and has_side_effects. + + can_fail has_side_effects +Discard YES YES +Float in YES YES +Float out NO NO +Duplicate YES NO + +How do we achieve these effects? - * A primop that is marked can_fail cannot be executed speculatively, - (becuase the might provoke the failure), but it can be repeated. - Why would you want to do that? Perhaps it might enable some - eta-expansion, if you can prove that the lambda is definitely - applied at least once. I guess we don't currently do that. +Note [primOpOkForSpeculation] + * The "no-float-out" thing is achieved by ensuring that we never + let-bind a can_fail or has_side_effects primop. The RHS of a + let-binding (which can float in and out freely) satisfies + exprOkForSpeculation. And exprOkForSpeculation is false of + can_fail and no_side_effect. - * A primop that is marked has_side_effects can be neither speculated - nor repeated; it must be executed exactly the right number of - times. + * So can_fail and no_side_effect primops will appear only as the + scrutinees of cases, and that's why the FloatIn pass is capable + of floating case bindings inwards. -So has_side_effects implies can_fail. We don't currently exploit -the case of primops that can_fail but do not have_side_effects. + * The no-duplicate thing is done via primOpIsCheap, by making + has_side_effects things (very very very) not-cheap! -Note [primOpOkForSpeculation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes we may choose to execute a PrimOp even though it isn't -certain that its result will be required; ie execute them -``speculatively''. The same thing as ``cheap eagerness.'' Usually -this is OK, because PrimOps are usually cheap, but it isn't OK for - * PrimOps that are expensive - * PrimOps which can fail - * PrimOps that have side effects - -Ok-for-speculation also means that it's ok *not* to execute the -primop. For example - case op a b of - r -> 3 -Here the result is not used, so we can discard the primop. Anything -that has side effects mustn't be dicarded in this way, of course! - -See also @primOpIsCheap@ (below). - -Note [primOpHasSideEffects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some primops have side-effects and so, for example, must not be -duplicated. - -This predicate means a little more than just "modifies the state of -the world". What it really means is "it cosumes the state on its -input". To see what this means, consider - - let - t = case readMutVar# v s0 of (# s1, x #) -> (S# s1, x) - y = case t of (s,x) -> x - in - ... y ... y ... - -Now, this is part of an ST or IO thread, so we are guaranteed by -construction that the program uses the state in a single-threaded way. -Whenever the state resulting from the readMutVar# is demanded, the -readMutVar# will be performed, and it will be ordered correctly with -respect to other operations in the monad. - -But there's another way this could go wrong: GHC can inline t into y, -and inline y. Then although the original readMutVar# will still be -correctly ordered with respect to the other operations, there will be -one or more extra readMutVar#s performed later, possibly out-of-order. -This really happened; see #3207. - -The property we need to capture about readMutVar# is that it consumes -the State# value on its input. We must retain the linearity of the -State#. - -Our fix for this is to declare any primop that must be used linearly -as having side-effects. When primOpHasSideEffects is True, -primOpOkForSpeculation will be False, and hence primOpIsCheap will -also be False, and applications of the primop will never be -duplicated. \begin{code} primOpHasSideEffects :: PrimOp -> Bool @@ -387,15 +404,19 @@ primOpCanFail :: PrimOp -> Bool #include "primop-can-fail.hs-incl" primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [primOpOkForSpeculation] + -- See Note [primOpOkForSpeculation and primOpOkForFloatOut] -- See comments with CoreUtils.exprOkForSpeculation primOpOkForSpeculation op = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) + +primOpOkForSideEffects :: PrimOp -> Bool +primOpOkForSideEffects op + = not (primOpHasSideEffects op) \end{code} -primOpIsCheap -~~~~~~~~~~~~~ +Note [primOpIsCheap] +~~~~~~~~~~~~~~~~~~~~ @primOpIsCheap@, as used in \tr{SimplUtils.lhs}. For now (HACK WARNING), we just borrow some other predicates for a what-should-be-good-enough test. "Cheap" means willing to call it more diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index c6991e1591..162a7025c0 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -50,13 +50,15 @@ module TysWiredIn ( -- * List listTyCon, nilDataCon, consDataCon, listTyCon_RDR, consDataCon_RDR, listTyConName, - mkListTy, + mkListTy, mkPromotedListTy, -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, tupleCon, + tupleTyCon, promotedTupleTyCon, + tupleCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, - unboxedSingletonTyCon, unboxedSingletonDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, -- * Unit @@ -86,13 +88,14 @@ import TysPrim import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) -import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) +import DataCon import Var import TyCon import TypeRep import RdrName import Name -import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), Arity, RecFlag(..), Boxity(..), HsBang(..) ) +import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), + Arity, RecFlag(..), Boxity(..), HsBang(..) ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array @@ -219,7 +222,6 @@ parrTyCon_RDR = nameRdrName parrTyConName eqTyCon_RDR = nameRdrName eqTyConName \end{code} - %************************************************************************ %* * \subsection{mkWiredInTyCon} @@ -321,6 +323,9 @@ tupleTyCon BoxedTuple i = fst (boxedTupleArr ! i) tupleTyCon UnboxedTuple i = fst (unboxedTupleArr ! i) tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) +promotedTupleTyCon :: TupleSort -> Arity -> TyCon +promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i) + tupleCon :: TupleSort -> Arity -> DataCon tupleCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially tupleCon BoxedTuple i = snd (boxedTupleArr ! i) @@ -367,6 +372,11 @@ unitDataConId = dataConWorkId unitDataCon pairTyCon :: TyCon pairTyCon = tupleTyCon BoxedTuple 2 +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon UnboxedTuple 0 +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleCon UnboxedTuple 0 + unboxedSingletonTyCon :: TyCon unboxedSingletonTyCon = tupleTyCon UnboxedTuple 1 unboxedSingletonDataCon :: DataCon @@ -619,6 +629,12 @@ mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] +mkPromotedListTy :: Type -> Type +mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] + +promotedListTyCon :: TyCon +promotedListTyCon = buildPromotedTyCon listTyCon + nilDataCon :: DataCon nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 5047b3cb63..48dd76873a 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1481,7 +1481,10 @@ primop RaiseOp "raise#" GenPrimOp -- one kind of bottom into another, as it is allowed to do in pure code. -- -- But we *do* want to know that it returns bottom after --- being applied to two arguments +-- being applied to two arguments, so that this function is strict in y +-- f x y | x>0 = raiseIO blah +-- | y>0 = return 1 +-- | otherwise = return 2 primop RaiseIOOp "raiseIO#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, b #) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index c919e46972..ecd2cd3147 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -20,7 +20,7 @@ module RnEnv ( HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndr, greRdrName, + lookupInstDeclBndr, lookupSubBndrOcc, greRdrName, lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -39,7 +39,7 @@ module RnEnv ( addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr, kindSigErr, polyKindsErr, perhapsForallMsg, + dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, HsDocContext(..), docOfHsDocContext ) where @@ -63,7 +63,7 @@ import Module ( ModuleName, moduleName ) import UniqFM import DataCon ( dataConFieldLabels ) import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR ) -import ErrUtils ( Message ) +import ErrUtils ( MsgDoc ) import SrcLoc import Outputable import Util @@ -267,7 +267,7 @@ lookupInstDeclBndr cls what rdr -- In an instance decl you aren't allowed -- to use a qualified name for the method -- (Although it'd make perfect sense.) - ; lookupSubBndr (ParentIs cls) doc rdr } + ; lookupSubBndrOcc (ParentIs cls) doc rdr } where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) @@ -304,11 +304,11 @@ lookupConstructorFields con_name -- unambiguous because there is only one field id 'fld' in scope. -- But currently it's rejected. -lookupSubBndr :: Parent -- NoParent => just look it up as usual - -- ParentIs p => use p to disambiguate - -> SDoc -> RdrName - -> RnM Name -lookupSubBndr parent doc rdr_name +lookupSubBndrOcc :: Parent -- NoParent => just look it up as usual + -- ParentIs p => use p to disambiguate + -> SDoc -> RdrName + -> RnM Name +lookupSubBndrOcc parent doc rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code = lookupExactOcc n @@ -323,6 +323,7 @@ lookupSubBndr parent doc rdr_name -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope [gre] -> do { addUsedRdrName gre (used_rdr_name gre) + -- Add a usage; this is an *occurrence* site ; return (gre_name gre) } [] -> do { addErr (unknownSubordinateErr doc rdr_name) ; return (mkUnboundName rdr_name) } @@ -453,32 +454,45 @@ lookupOccRn rdr_name = do -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupPromotedOccRn :: RdrName -> RnM Name --- see Note [Demotion] in OccName -lookupPromotedOccRn rdr_name = do { - -- 1. lookup the name - opt_name <- lookupOccRn_maybe rdr_name - ; case opt_name of - -- 1.a. we found it! - Just name -> return name - -- 1.b. we did not find it -> 2 - Nothing -> do { - ; -- 2. maybe it was implicitly promoted - case demoteRdrName rdr_name of - -- 2.a it was not in a promoted namespace - Nothing -> err - -- 2.b let's try every thing again -> 3 - Just demoted_rdr_name -> do { - ; poly_kinds <- xoptM Opt_PolyKinds - -- 3. lookup again - ; opt_demoted_name <- lookupOccRn_maybe demoted_rdr_name ; - ; case opt_demoted_name of - -- 3.a. it was implicitly promoted, but confirm that we can promote - -- JPM: We could try to suggest turning on PolyKinds here - Just demoted_name -> if poly_kinds then return demoted_name else err - -- 3.b. use rdr_name to have a correct error message - Nothing -> err } } } - where err = unboundName WL_Any rdr_name +-- see Note [Demotion] +lookupPromotedOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of { + Just name -> return name ; + Nothing -> + + do { -- Maybe it's the name of a *data* constructor + data_kinds <- xoptM Opt_DataKinds + ; mb_demoted_name <- case demoteRdrName rdr_name of + Just demoted_rdr -> lookupOccRn_maybe demoted_rdr + Nothing -> return Nothing + ; case mb_demoted_name of + Nothing -> unboundName WL_Any rdr_name + Just demoted_name + | data_kinds -> return demoted_name + | otherwise -> unboundNameX WL_Any rdr_name suggest_dk }}} + where + suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") +\end{code} + +Note [Demotion] +~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) + +\begin{code} -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) lookupOccRn_maybe rdr_name @@ -493,7 +507,12 @@ lookupOccRn_maybe rdr_name { -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if there -- was an "import qualified M" declaration for every module. - allow_qual <- doptM Opt_ImplicitImportQualified + -- But we DONT allow it under Safe Haskell as we need to check + -- imports. We can and should instead check the qualified import + -- but at the moment this requires some refactoring so leave as a TODO + ; dflags <- getDynFlags + ; let allow_qual = dopt Opt_ImplicitImportQualified dflags && + not (safeDirectImpsReq dflags) ; is_ghci <- getIsGHCi -- This test is not expensive, -- and only happens for failed lookups @@ -658,7 +677,7 @@ lookupSigOccRn ctxt sig lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either Message Name) + -> RdrName -> RnM (Either MsgDoc Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- @@ -669,6 +688,11 @@ lookupBindGroupOcc ctxt what rdr_name ; return (Right n') } -- Maybe we should check the side conditions -- but it's a pain, and Exact things only show -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n' <- lookupOrig rdr_mod rdr_occ + ; return (Right n') } + | otherwise = case ctxt of HsBootCtxt -> lookup_top @@ -1093,7 +1117,7 @@ checkShadowedOccs (global_env,local_env) loc_occs -- Returns False for record selectors that are shadowed, when -- punning or wild-cards are on (cf Trac #2723) is_shadowed_gre gre@(GRE { gre_par = ParentIs _ }) - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; if (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags) then do { is_fld <- is_rec_fld gre; return (not is_fld) } else return True } @@ -1119,13 +1143,16 @@ data WhereLooking = WL_Any -- Any binding | WL_LocalTop -- Any top-level binding in this module unboundName :: WhereLooking -> RdrName -> RnM Name -unboundName where_look rdr_name +unboundName wl rdr = unboundNameX wl rdr empty + +unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name +unboundNameX where_look rdr_name extra = do { show_helpful_errors <- doptM Opt_HelpfulErrors - ; let err = unknownNameErr rdr_name + ; let err = unknownNameErr rdr_name $$ extra ; if not show_helpful_errors then addErr err - else do { extra_err <- unknownNameSuggestErr where_look rdr_name - ; addErr (err $$ extra_err) } + else do { suggestions <- unknownNameSuggestErr where_look rdr_name + ; addErr (err $$ suggestions) } ; env <- getGlobalRdrEnv; ; traceRn (vcat [unknownNameErr rdr_name, @@ -1412,10 +1439,10 @@ kindSigErr thing = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use -XKindSignatures")) -polyKindsErr :: Outputable a => a -> SDoc -polyKindsErr thing +dataKindsErr :: Outputable a => a -> SDoc +dataKindsErr thing = hang (ptext (sLit "Illegal kind:") <+> quotes (ppr thing)) - 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) + 2 (ptext (sLit "Perhaps you intended to use -XDataKinds")) badQualBndrErr :: RdrName -> SDoc diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 04877331d0..7caae61027 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -1239,7 +1239,7 @@ checkStmt :: HsStmtContext Name -> LStmt RdrName -> RnM () checkStmt ctxt (L _ stmt) - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of Nothing -> return () Just extra -> addErr (msg $$ extra) } diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 5ca81d6db4..70d891dcbf 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -1,24 +1,17 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RnExpr where import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) + -> RnM (LHsExpr Name, FreeVars) rnStmts :: --forall thing. - HsStmtContext Name -> [LStmt RdrName] + HsStmtContext Name -> [LStmt RdrName] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 090a17747f..b1a61db2a2 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -60,12 +60,14 @@ and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends on. To avoid this we make use of the property that if a modules Safe Haskell mode changes, this triggers a recompilation from that module in the dependcy -graph. So we can just worry mostly about direct imports. There is one trust -property that can change for a package though without recompliation being -triggered, package trust. So we must check that all packages a module -tranitively depends on to be trusted are still trusted when we are compiling -this module (as due to recompilation avoidance some modules below may not be -considered trusted any more without recompilation being triggered). +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompliation being triggered: package trust. So we must check that all +packages a module tranitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). We handle this by augmenting the existing transitive list of packages a module M depends on with a bool for each package that says if it must be trusted when the @@ -110,7 +112,7 @@ haskell at all and simply imports B, should A inherit all the the trust requirements from B? Should A now also require that a package p is trusted since B required it? -We currently say no but I saying yes also makes sense. The difference is, if a +We currently say no but saying yes also makes sense. The difference is, if a module M that doesn't use Safe Haskell imports a module N that does, should all the trusted package requirements be dropped since M didn't declare that it cares about Safe Haskell (so -XSafe is more strongly associated with the module doing @@ -198,7 +200,7 @@ rnImportDecl this_mod -- and indeed we shouldn't do it here because the existence of -- the non-boot module depends on the compilation order, which -- is not deterministic. The hs-boot test can show this up. - dflags <- getDOpts + dflags <- getDynFlags warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ @@ -484,12 +486,8 @@ getLocalNonValBinders fixity_env hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls }) - = do { -- Separate out the family instance declarations - let (tyinst_decls, tycl_decls_noinsts) - = partition (isFamInstDecl . unLoc) (concat tycl_decls) - - -- Process all type/class decls *except* family instances - ; tc_avails <- mapM new_tc tycl_decls_noinsts + = do { -- Process all type/class decls *except* family instances + ; tc_avails <- mapM new_tc (concat tycl_decls) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env ; setEnvs envs $ do { -- Bring these things into scope first @@ -497,7 +495,6 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; ti_avails <- mapM (new_ti Nothing) tyinst_decls ; nti_avails <- concatMapM new_assoc inst_decls -- Finish off with value binders: @@ -508,7 +505,7 @@ getLocalNonValBinders fixity_env | otherwise = for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs - ; let avails = ti_avails ++ nti_avails ++ val_avails + ; let avails = nti_avails ++ val_avails new_bndrs = availsToNameSet avails `unionNameSets` availsToNameSet tc_avails ; envs <- extendGlobalRdrEnvRn avails fixity_env @@ -527,20 +524,25 @@ getLocalNonValBinders fixity_env ; return (Avail nm) } new_tc tc_decl -- NOT for type/data instances - = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) + = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl) + ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } - new_ti :: Maybe Name -> LTyClDecl RdrName -> RnM AvailInfo + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances - = do { main_name <- lookupTcdName mb_cls (unLoc ti_decl) + = ASSERT( isFamInstDecl ti_decl ) + do { main_name <- lookupTcdName mb_cls ti_decl ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) ; return (AvailTC (unLoc main_name) sub_names) } -- main_name is not bound here! new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] - new_assoc (L _ (InstDecl inst_ty _ _ ats)) + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) = do { mb_cls_nm <- get_cls_parent inst_ty - ; mapM (new_ti mb_cls_nm) ats } + ; mapM (new_ti mb_cls_nm . unLoc) ats } where get_cls_parent inst_ty | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty @@ -549,7 +551,8 @@ getLocalNonValBinders fixity_env = return Nothing lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- Used for TyData and TySynonym only +-- Used for TyData and TySynonym only, +-- both ordinary ones and family instances -- See Note [Family instance binders] lookupTcdName mb_cls tc_decl | not (isFamInstDecl tc_decl) -- The normal case @@ -723,9 +726,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See the discussion at occ_env. - lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] + lookup_ie :: Bool -> IE RdrName -> MaybeErr MsgDoc [(IE Name,AvailInfo)] lookup_ie opt_typeFamilies ie - = let bad_ie :: MaybeErr Message a + = let bad_ie :: MaybeErr MsgDoc a bad_ie = Failed (badImportItemErr iface decl_spec ie all_avails) lookup_name rdr @@ -962,7 +965,7 @@ rnExports explicit_mod exports -- written "module Main where ..." -- Reason: don't want to complain about 'main' not in scope -- in interactive mode - ; dflags <- getDOpts + ; dflags <- getDynFlags ; let real_exports | explicit_mod = exports | ghcLink dflags == LinkInMemory = Nothing @@ -1509,7 +1512,10 @@ warnUnusedImport (L loc decl, used, unused) <+> ptext (sLit "import") <+> pp_mod <> parens empty ] msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused), text "from module" <+> quotes pp_mod <+> pp_not_used] - pp_herald = text "The import of" + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | ideclQualified decl = text "qualified" + | otherwise = empty pp_mod = ppr (unLoc (ideclName decl)) pp_not_used = text "is redundant" \end{code} @@ -1678,7 +1684,7 @@ typeItemErr name wherestr ptext (sLit "Use -XTypeFamilies to enable this extension") ] exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName - -> Message + -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 = vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon , ppr_export ie1' name1' diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 740acc42c5..7dd76bd4e6 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -487,7 +487,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld , hsRecFieldArg = arg , hsRecPun = pun }) - = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndr parent doc) fld + = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndrOcc parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 31c7c336be..54f95016c7 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -424,7 +424,11 @@ patchCCallTarget packageId callTarget \begin{code} rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) -rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) +rnSrcInstDecl (FamInstDecl ty_decl) + = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl + ; return (FamInstDecl ty_decl', fvs) } + +rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' @@ -460,7 +464,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' - ; return (InstDecl inst_ty' mbinds' uprags' ats', + ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs `plusFV` hsSigsFVs spec_inst_prags' `plusFV` extractHsTyNames inst_ty') } @@ -682,7 +686,7 @@ rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" rnHsVectDecl (HsVectInstIn instTy) = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', emptyFVs) + ; return (HsVectInstIn instTy', extractHsTyNames instTy') } rnHsVectDecl (HsVectInstOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" @@ -749,7 +753,7 @@ rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]] -- Rename the declarations and do depedency analysis on them rnTyClDecls extra_deps tycl_ds = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds) - ; thisPkg <- fmap thisPackage getDOpts + ; thisPkg <- fmap thisPackage getDynFlags ; let add_boot_deps :: FreeVars -> FreeVars -- See Note [Extra dependencies from .hs-boot files] add_boot_deps fvs | any (isInPackage thisPkg) (nameSetToList fvs) @@ -764,6 +768,7 @@ rnTyClDecls extra_deps tycl_ds all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs' + ; traceRn (text "rnTycl" <+> (ppr ds_w_fvs $$ ppr sccs)) ; return (map flattenSCC sccs, all_fvs) } @@ -995,12 +1000,16 @@ depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)] depAnalTyClDecls ds_w_fvs = stronglyConnCompFromEdgedVertices edges where - edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs)) + edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs)) | (d, fvs) <- ds_w_fvs ] - get_assoc n = lookupNameEnv assoc_env n `orElse` n + + -- We also need to consider data constructor names since + -- they may appear in types because of promotion. + get_parent n = lookupNameEnv assoc_env n `orElse` n + + assoc_env :: NameEnv Name -- Maps a data constructor back + -- to its parent type constructor assoc_env = mkNameEnv assoc_env_list - -- We also need to consider data constructor names since they may - -- appear in types because of promotion. assoc_env_list = do (L _ d, _) <- ds_w_fvs case d of @@ -1055,9 +1064,9 @@ rnConDecls condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs - , con_cxt = cxt, con_details = details - , con_res = res_ty, con_doc = mb_doc - , con_old_rec = old_rec, con_explicit = expl }) + , con_cxt = cxt, con_details = details + , con_res = res_ty, con_doc = mb_doc + , con_old_rec = old_rec, con_explicit = expl }) = do { addLocM checkConName name ; when old_rec (addWarn (deprecRecSyntax decl)) ; new_name <- lookupLocatedTopBndrRn name @@ -1084,35 +1093,43 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDeclDetails doc details - ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty + ; (new_details', new_res_ty) <- rnConResult doc (unLoc new_name) new_details res_ty ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} where doc = ConDeclCtx name get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys)) -rnConResult :: HsDocContext +rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] -> ResType RdrName -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], ResType Name) -rnConResult _ details ResTyH98 = return (details, ResTyH98) -rnConResult doc details (ResTyGADT ty) +rnConResult _ _ details ResTyH98 = return (details, ResTyH98) +rnConResult doc con details (ResTyGADT ty) = do { ty' <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, -- now the renamer has dealt with fixities -- See Note [Sorting out the result type] in RdrHsSyn - details' = case details of - RecCon {} -> details - PrefixCon {} -> PrefixCon arg_tys - InfixCon {} -> pprPanic "rnConResult" (ppr ty) - -- See Note [Sorting out the result type] in RdrHsSyn - - ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False }) - (addErr (badRecResTy (docOfHsDocContext doc))) - ; return (details', ResTyGADT res_ty) } + ; case details of + InfixCon {} -> pprPanic "rnConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + RecCon {} -> do { unless (null arg_tys) + (addErr (badRecResTy (docOfHsDocContext doc))) + ; return (details, ResTyGADT res_ty) } + + PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] + , [ty1,ty2] <- arg_tys + -> do { fix_env <- getFixityEnv + ; return (if con `elemNameEnv` fix_env + then InfixCon ty1 ty2 + else PrefixCon arg_tys + , ResTyGADT res_ty) } + | otherwise + -> return (PrefixCon arg_tys, ResTyGADT res_ty) } rnConDeclDetails :: HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] @@ -1161,6 +1178,18 @@ badDataCon name = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)] \end{code} +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int %********************************************************* %* * @@ -1190,7 +1219,7 @@ extendRecordFieldEnv tycl_decls inst_decls all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls , L _ con <- cons ] all_tycl_decls = at_tycl_decls ++ concat tycl_decls - at_tycl_decls = instDeclATs inst_decls -- Do not forget associated types! + at_tycl_decls = instDeclFamInsts inst_decls -- Do not forget associated types! get_con (ConDecl { con_name = con, con_details = RecCon flds }) (RecFields env fld_set) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index df6008b574..3b86d0b38c 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -196,8 +196,8 @@ rnHsTyKi isType doc (HsFunTy ty1 ty2) = do else return (HsFunTy ty1' ty2') rnHsTyKi isType doc listTy@(HsListTy ty) = do - poly_kinds <- xoptM Opt_PolyKinds - unless (poly_kinds || isType) (addErr (polyKindsErr listTy)) + data_kinds <- xoptM Opt_DataKinds + unless (data_kinds || isType) (addErr (dataKindsErr listTy)) ty' <- rnLHsTyKi isType doc ty return (HsListTy ty') @@ -216,8 +216,8 @@ rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do - poly_kinds <- xoptM Opt_PolyKinds - unless (poly_kinds || isType) (addErr (polyKindsErr tupleTy)) + data_kinds <- xoptM Opt_DataKinds + unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) tys' <- mapM (rnLHsTyKi isType doc) tys return (HsTupleTy tup_con tys') diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 1e4def3f14..829c2ca40f 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -162,7 +162,7 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules | otherwise = Err.debugTraceMsg dflags 2 $ - (text "Result size of" <+> hdr <+> equals <+> int (coreBindsSize binds)) + (sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]) -- Report result size -- This has the side effect of forcing the intermediate to be evaluated @@ -184,7 +184,7 @@ lintPassResult dflags pass binds ; displayLintResults dflags pass warns errs binds } displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.Message -> Bag Err.Message -> CoreProgram + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram -> IO () displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) @@ -865,8 +865,8 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count }) -- Convenience accessors for useful fields of HscEnv -getDynFlags :: CoreM DynFlags -getDynFlags = fmap hsc_dflags getHscEnv +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv -- | The original name cache is the current mapping from 'Module' and -- 'OccName' to a compiler-wide unique 'Name' diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 6745fda8cb..0601d7b7bf 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -24,7 +24,8 @@ module FloatIn ( floatInwards ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( exprIsHNF, exprIsDupable ) +import MkCore +import CoreUtils ( exprIsDupable, exprIsExpandable, exprOkForSideEffects ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var @@ -119,26 +120,28 @@ the closure for a is not built. %************************************************************************ \begin{code} -type FreeVarsSet = IdSet +type FreeVarSet = IdSet +type BoundVarSet = IdSet -type FloatingBinds = [(CoreBind, FreeVarsSet)] - -- In reverse dependency order (innermost binder first) - - -- The FreeVarsSet is the free variables of the binding. In the case +data FloatInBind = FB BoundVarSet FreeVarSet FloatBind + -- The FreeVarSet is the free variables of the binding. In the case -- of recursive bindings, the set doesn't include the bound -- variables. -fiExpr :: FloatingBinds -- Binds we're trying to drop +type FloatInBinds = [FloatInBind] + -- In reverse dependency order (innermost binder first) + +fiExpr :: FloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty -fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) -fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co) +fiExpr to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr to_drop (_, AnnCast expr (fvs_co, co)) - = mkCoLets' (drop_here ++ co_drop) $ + = wrapFloats (drop_here ++ co_drop) $ Cast (fiExpr e_drop expr) co where [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop @@ -149,10 +152,16 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. \begin{code} -fiExpr to_drop (_,AnnApp fun arg) - = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg)) +fiExpr to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) + | noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $ + App (fiExpr fun_drop fun) (fiExpr [] arg) + -- It's inconvenient to test for an unlifted arg here, + -- and it really doesn't matter if we float into one + | otherwise = wrapFloats drop_here $ + App (fiExpr fun_drop fun) (fiExpr arg_drop arg) where - [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop + [drop_here, fun_drop, arg_drop] + = sepBindsByDropPoint False [freeVarsOf fun, arg_fvs] to_drop \end{code} Note [Floating in past a lambda group] @@ -199,7 +208,7 @@ fiExpr to_drop lam@(_, AnnLam _ _) = mkLams bndrs (fiExpr to_drop body) | otherwise -- Dump it all here - = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body)) + = wrapFloats to_drop (mkLams bndrs (fiExpr [] body)) where (bndrs, body) = collectAnnBndrs lam @@ -220,7 +229,7 @@ We don't float lets inwards past an SCC. fiExpr to_drop (_, AnnTick tickish expr) | tickishScoped tickish = -- Wimp out for now - we could push values in - mkCoLets' to_drop (Tick tickish (fiExpr [] expr)) + wrapFloats to_drop (Tick tickish (fiExpr [] expr)) | otherwise = Tick tickish (fiExpr to_drop expr) @@ -266,7 +275,7 @@ can't have unboxed bindings. So we make "extra_fvs" which is the rhs_fvs of such bindings, and arrange to dump bindings that bind extra_fvs before the entire let. -Note [extra_fvs (s): free variables of rules] +Note [extra_fvs (2): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider let x{rule mentioning y} = rhs in body @@ -280,13 +289,13 @@ idFreeVars. fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr new_to_drop body where - body_fvs = freeVarsOf body + body_fvs = freeVarsOf body `delVarSet` id rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] extra_fvs | noFloatIntoRhs ann_rhs || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs | otherwise = rule_fvs - -- See Note [extra_fvs (2): avoid floating into RHS] + -- See Note [extra_fvs (1): avoid floating into RHS] -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs @@ -294,7 +303,8 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself + [FB (unitVarSet id) rhs_fvs' + (FloatLet (NonRec id rhs'))] ++ -- the new binding itself extra_binds ++ -- bindings from extra_fvs shared_binds -- the bindings used both in rhs and body @@ -308,7 +318,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) where (ids, rhss) = unzip bindings rhss_fvs = map freeVarsOf rhss - body_fvs = freeVarsOf body + body_fvs = freeVarsOf body -- See Note [extra_fvs (1,2)] rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids @@ -320,7 +330,8 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop new_to_drop = body_binds ++ -- the bindings used only in the body - [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++ + [FB (mkVarSet ids) rhs_fvs' + (FloatLet (Rec (fi_bind rhss_binds bindings)))] ++ -- The new binding itself extra_binds ++ -- Note [extra_fvs (1,2)] shared_binds -- Used in more than one place @@ -330,7 +341,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) rule_fvs -- Don't forget the rule variables! -- Push rhs_binds into the right hand side of the binding - fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss + fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss -> [(Id, CoreExprWithFVs)] -> [(Id, CoreExpr)] @@ -344,17 +355,32 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. \begin{code} +fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)]) + | isUnLiftedType (idType case_bndr) + , exprOkForSideEffects (deAnnotate scrut) + = wrapFloats shared_binds $ + fiExpr (case_float : rhs_binds) rhs + where + case_float = FB (unitVarSet case_bndr) scrut_fvs + (FloatCase scrut' case_bndr DEFAULT []) + scrut' = fiExpr scrut_binds scrut + [shared_binds, scrut_binds, rhs_binds] + = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop + rhs_fvs = freeVarsOf rhs `delVarSet` case_bndr + scrut_fvs = freeVarsOf scrut + fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) - = mkCoLets' drop_here1 $ - mkCoLets' drop_here2 $ + = wrapFloats drop_here1 $ + wrapFloats drop_here2 $ Case (fiExpr scrut_drops scrut) case_bndr ty (zipWith fi_alt alts_drops_s alts) where -- Float into the scrut and alts-considered-together just like App - [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop + [drop_here1, scrut_drops, alts_drops] + = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop -- Float into the alts with the is_case flag set - (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops + (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts @@ -376,7 +402,9 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- boxing constructor into it, else we box it every time which is very bad -- news indeed. -noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... +noFloatIntoRhs rhs = exprIsExpandable (deAnnotate' rhs) + -- We'd just float right back out again... + -- Should match the test in SimplEnv.doFloatFromRhs is_one_shot :: Var -> Bool is_one_shot b = isId b && isOneShotBndr b @@ -407,9 +435,9 @@ We have to maintain the order on these drop-point-related lists. \begin{code} sepBindsByDropPoint :: Bool -- True <=> is case expression - -> [FreeVarsSet] -- One set of FVs per drop point - -> FloatingBinds -- Candidate floaters - -> [FloatingBinds] -- FIRST one is bindings which must not be floated + -> [FreeVarSet] -- One set of FVs per drop point + -> FloatInBinds -- Candidate floaters + -> [FloatInBinds] -- FIRST one is bindings which must not be floated -- inside any drop point; the rest correspond -- one-to-one with the input list of FV sets @@ -419,7 +447,7 @@ sepBindsByDropPoint -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B. -type DropBox = (FreeVarsSet, FloatingBinds) +type DropBox = (FreeVarSet, FloatInBinds) sepBindsByDropPoint _is_case drop_pts [] = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens @@ -427,19 +455,19 @@ sepBindsByDropPoint _is_case drop_pts [] sepBindsByDropPoint is_case drop_pts floaters = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) where - go :: FloatingBinds -> [DropBox] -> [FloatingBinds] + go :: FloatInBinds -> [DropBox] -> [FloatInBinds] -- The *first* one in the argument list is the drop_here set - -- The FloatingBinds in the lists are in the reverse of - -- the normal FloatingBinds order; that is, they are the right way round! + -- The FloatInBinds in the lists are in the reverse of + -- the normal FloatInBinds order; that is, they are the right way round! go [] drop_boxes = map (reverse . snd) drop_boxes - go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes) + go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes) = go binds new_boxes where -- "here" means the group of bindings dropped at the top of the fork - (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) + (used_here : used_in_flags) = [ fvs `intersectsVarSet` bndrs | (fvs, _) <- drop_boxes] drop_here = used_here || not can_push @@ -460,7 +488,7 @@ sepBindsByDropPoint is_case drop_pts floaters || (is_case && -- We are looking at case alternatives n_used_alts > 1 && -- It's used in more than one n_used_alts < n_alts && -- ...but not all - bindIsDupable bind) -- and we can duplicate the binding + floatIsDupable bind) -- and we can duplicate the binding new_boxes | drop_here = (insert here_box : fork_boxes) | otherwise = (here_box : new_fork_boxes) @@ -476,14 +504,19 @@ sepBindsByDropPoint is_case drop_pts floaters go _ _ = panic "sepBindsByDropPoint/go" -floatedBindsFVs :: FloatingBinds -> FreeVarsSet -floatedBindsFVs binds = unionVarSets (map snd binds) +floatedBindsFVs :: FloatInBinds -> FreeVarSet +floatedBindsFVs binds = foldr (unionVarSet . fbFVs) emptyVarSet binds + +fbFVs :: FloatInBind -> VarSet +fbFVs (FB _ fvs _) = fvs -mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr -mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop - -- Remember to_drop is in *reverse* dependency order +wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr +-- Remember FloatInBinds is in *reverse* dependency order +wrapFloats [] e = e +wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e) -bindIsDupable :: Bind CoreBndr -> Bool -bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs -bindIsDupable (NonRec _ r) = exprIsDupable r +floatIsDupable :: FloatBind -> Bool +floatIsDupable (FloatCase scrut _ _ _) = exprIsDupable scrut +floatIsDupable (FloatLet (Rec prs)) = all (exprIsDupable . snd) prs +floatIsDupable (FloatLet (NonRec _ r)) = exprIsDupable r \end{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 00d6554790..18fc9b4af4 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -17,12 +17,12 @@ module FloatOut ( floatOutwards ) where import CoreSyn import CoreUtils +import MkCore import CoreArity ( etaExpand ) import CoreMonad ( FloatOutSwitches(..) ) import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( dumpIfSet_dyn ) -import DataCon ( DataCon ) import Id ( Id, idArity, isBottomingId ) import Var ( Var ) import SetLevels @@ -326,7 +326,7 @@ floatExpr (Let bind body) floatExpr (Case scrut (TB case_bndr case_spec) ty alts) = case case_spec of FloatMe dest_lvl -- Case expression moves - | [(DataAlt con, bndrs, rhs)] <- alts + | [(con@(DataAlt {}), bndrs, rhs)] <- alts -> case floatExpr scrut of { (fse, fde, scrut') -> case floatExpr rhs of { (fsb, fdb, rhs') -> let @@ -444,13 +444,6 @@ partitionByMajorLevel. \begin{code} -data FloatBind - = FloatLet FloatLet - - | FloatCase CoreExpr Id DataCon [Var] - -- case e of y { C ys -> ... } - -- See Note [Floating cases] in SetLevels - type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted type MajorEnv = M.IntMap MinorEnv -- Keyed by major level type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level @@ -491,7 +484,7 @@ flattenMinor = M.fold unionBags emptyBag emptyFloats :: FloatBinds emptyFloats = FB emptyBag M.empty -unitCaseFloat :: Level -> CoreExpr -> Id -> DataCon -> [Var] -> FloatBinds +unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds unitCaseFloat (Level major minor) e b con bs = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs)))) @@ -514,12 +507,7 @@ plusMinor = M.unionWith unionBags install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr - = foldrBag install_group expr defn_groups - where - install_group (FloatLet defns) body - = Let defns body - install_group (FloatCase e b con bs) body - = Case e b (exprType body) [(DataAlt con, bs, body)] + = foldrBag wrapFloat expr defn_groups partitionByLevel :: Level -- Partitioning level diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index a80dea4603..beb64cb061 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -423,7 +423,7 @@ Things to note * We only do this with a single-alternative case Note [Check the output scrutinee for okForSpec] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this: case x of y { A -> ....(case y of alts).... @@ -432,7 +432,7 @@ Because of the binder-swap, the inner case will get substituted to (case x of ..). So when testing whether the scrutinee is okForSpecuation we must be careful to test the *result* scrutinee ('x' in this case), not the *input* one 'y'. The latter *is* ok for -speculation here, but the former is not -- and ideed we can't float +speculation here, but the former is not -- and indeed we can't float the inner case out, at least not unless x is also evaluated at its binding site. diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 62f96e7c6e..8661d71e04 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -397,6 +397,7 @@ classifyFF (NonRec bndr rhs) | otherwise = FltCareful doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool +-- If you change this function look also at FloatIn.noFloatFromRhs doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) = not (isNilOL fs) && want_to_float && can_float where diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 647da72d16..e025e6cb34 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -15,7 +15,7 @@ module SimplMonad ( -- The monad SimplM, initSmpl, - getDOptsSmpl, getSimplRules, getFamEnvs, + getSimplRules, getFamEnvs, -- Unique supply MonadUnique(..), newId, @@ -31,7 +31,7 @@ import Type ( Type ) import FamInstEnv ( FamInstEnv ) import Rules ( RuleBase ) import UniqSupply -import DynFlags ( DynFlags( simplTickFactor ) ) +import DynFlags import CoreMonad import Outputable import FastString @@ -148,8 +148,8 @@ instance MonadUnique SimplM where = SM (\_st_env us sc -> case splitUniqSupply us of (us1, us2) -> (uniqsFromSupply us1, us2, sc)) -getDOptsSmpl :: SimplM DynFlags -getDOptsSmpl = SM (\st_env us sc -> (st_flags st_env, us, sc)) +instance HasDynFlags SimplM where + getDynFlags = SM (\st_env us sc -> (st_flags st_env, us, sc)) getSimplRules :: SimplM RuleBase getSimplRules = SM (\st_env us sc -> (st_rules st_env, us, sc)) diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 86dc88ddd1..ad6fe5488b 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1054,7 +1054,7 @@ mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam _b [] body = return body mkLam _env bndrs body - = do { dflags <- getDOptsSmpl + = do { dflags <- getDynFlags ; mkLam' dflags bndrs body } where mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr @@ -1125,7 +1125,7 @@ because the latter is not well-kinded. tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] tryEtaExpand env bndr rhs - = do { dflags <- getDOptsSmpl + = do { dflags <- getDynFlags ; (new_arity, new_rhs) <- try_expand dflags ; WARN( new_arity < old_arity || new_arity < _dmd_arity, diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 2d84249e97..900d70c7de 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -221,7 +221,7 @@ simplTopBinds env0 binds0 -- It's rather as if the top-level binders were imported. -- See note [Glomming] in OccurAnal. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) - ; dflags <- getDOptsSmpl + ; dflags <- getDynFlags ; let dump_flag = dopt Opt_D_verbose_core2core dflags ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone @@ -976,11 +976,6 @@ simplType env ty --------------------------------- simplCoercionF :: SimplEnv -> InCoercion -> SimplCont -> SimplM (SimplEnv, OutExpr) --- We are simplifying a term of form (Coercion co) --- Simplify the InCoercion, and then try to combine with the --- context, to implememt the rule --- (Coercion co) |> g --- = Coercion (syn (nth 0 g) ; co ; nth 1 g) simplCoercionF env co cont = do { co' <- simplCoercion env co ; rebuild env (Coercion co') cont } @@ -1164,7 +1159,7 @@ rebuild env expr cont = case cont of Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation + -- NB: mkCast implements the (Coercion co |> g) optimisation Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr @@ -1388,7 +1383,7 @@ simplIdF env var cont completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr) completeCall env var cont = do { ------------- Try inlining ---------------- - dflags <- getDOptsSmpl + dflags <- getDynFlags ; let (lone_variable, arg_infos, call_cont) = contArgs cont -- The args are OutExprs, obtained by *lazily* substituting -- in the args found in cont. These args are only examined @@ -1564,7 +1559,7 @@ tryRules env rules fn args call_cont Just (rule, rule_rhs) -> do { checkedTick (RuleFired (ru_name rule)) - ; dflags <- getDOptsSmpl + ; dflags <- getDynFlags ; trace_dump dflags rule rule_rhs $ return (Just (ruleArity rule, rule_rhs)) }}} where @@ -1766,7 +1761,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont | all isDeadBinder bndrs -- bndrs are [InId] , if isUnLiftedType (idType case_bndr) - then ok_for_spec -- Satisfy the let-binding invariant + then elim_unlifted -- Satisfy the let-binding invariant else elim_lifted = do { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut), -- ppr strict_case_bndr, ppr (scrut_is_var scrut), @@ -1786,6 +1781,14 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont || (is_plain_seq && ok_for_spec) -- Note: not the same as exprIsHNF + elim_unlifted + | is_plain_seq = exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it, + -- _unless_ the scrutinee has side effects + | otherwise = exprOkForSpeculation scrut + -- The case-binder is alive, but we may be able + -- turn the case into a let, if the expression is ok-for-spec + ok_for_spec = exprOkForSpeculation scrut is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) @@ -1832,7 +1835,7 @@ reallyRebuildCase env scrut case_bndr alts cont -- Check for empty alternatives ; if null alts' then missingAlt env case_bndr alts cont else do - { dflags <- getDOptsSmpl + { dflags <- getDynFlags ; case_expr <- mkCase dflags scrut' case_bndr' alts' -- Notice that rebuild gets the in-scope set from env', not alt_env diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index d54294f4f3..ea1fab7eea 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -24,7 +24,7 @@ import PrimOp ( primOpType ) import Literal ( literalType ) import Maybes import Name ( getSrcLoc ) -import ErrUtils ( Message, mkLocMessage ) +import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) import TypeRep import Type import TyCon @@ -288,8 +288,8 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do newtype LintM a = LintM { unLintM :: [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag Message -- Error messages so far - -> (a, Bag Message) -- Result and error messages (if any) + -> Bag MsgDoc -- Error messages so far + -> (a, Bag MsgDoc) -- Result and error messages (if any) } data LintLocInfo @@ -316,7 +316,7 @@ pp_binders bs \end{code} \begin{code} -initL :: LintM a -> Maybe Message +initL :: LintM a -> Maybe MsgDoc initL (LintM m) = case (m [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then @@ -342,19 +342,19 @@ thenL_ m k = LintM $ \loc scope errs \end{code} \begin{code} -checkL :: Bool -> Message -> LintM () +checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = addErrL msg -addErrL :: Message -> LintM () +addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc) -addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message +addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage l (hdr $$ msg) + in mkLocMessage SevWarning l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a @@ -387,7 +387,7 @@ have long since disappeared. \begin{code} checkFunApp :: Type -- The function type -> [Type] -- The arg type(s) - -> Message -- Error message + -> MsgDoc -- Error message -> LintM (Maybe Type) -- Just ty => result type is accurate checkFunApp fun_ty arg_tys msg @@ -399,7 +399,7 @@ checkFunApp fun_ty arg_tys msg (mb_ty, mb_msg) = cfa True fun_ty arg_tys cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe Message) -- Errors? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -468,7 +468,7 @@ checkInScope id = LintM $ \loc scope errs else ((), errs) -checkTys :: Type -> Type -> Message -> LintM () +checkTys :: Type -> Type -> MsgDoc -> LintM () checkTys ty1 ty2 msg = LintM $ \loc _scope errs -> if (ty1 `stgEqType` ty2) then ((), errs) @@ -476,35 +476,35 @@ checkTys ty1 ty2 msg = LintM $ \loc _scope errs \end{code} \begin{code} -_mkCaseAltMsg :: [StgAlt] -> Message +_mkCaseAltMsg :: [StgAlt] -> MsgDoc _mkCaseAltMsg _alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (empty) -- LATER: ppr alts -mkDefltMsg :: Id -> TyCon -> Message +mkDefltMsg :: Id -> TyCon -> MsgDoc mkDefltMsg bndr tc = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) (ppr bndr $$ ppr (idType bndr) $$ ppr tc) -mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message +mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc mkFunAppMsg fun_ty arg_tys expr = vcat [text "In a function application, function type doesn't match arg types:", hang (ptext (sLit "Function type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)), hang (ptext (sLit "Expression:")) 4 (ppr expr)] -mkRhsConMsg :: Type -> [Type] -> Message +mkRhsConMsg :: Type -> [Type] -> MsgDoc mkRhsConMsg fun_ty arg_tys = vcat [text "In a RHS constructor application, con type doesn't match arg types:", hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))] -mkAltMsg1 :: Type -> Message +mkAltMsg1 :: Type -> MsgDoc mkAltMsg1 ty = ($$) (text "In a case expression, type of scrutinee does not match patterns") (ppr ty) -mkAlgAltMsg2 :: Type -> DataCon -> Message +mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc mkAlgAltMsg2 ty con = vcat [ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", @@ -512,7 +512,7 @@ mkAlgAltMsg2 ty con ppr con ] -mkAlgAltMsg3 :: DataCon -> [Id] -> Message +mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc mkAlgAltMsg3 con alts = vcat [ text "In some algebraic case alternative, number of arguments doesn't match constructor:", @@ -520,7 +520,7 @@ mkAlgAltMsg3 con alts ppr alts ] -mkAlgAltMsg4 :: Type -> Id -> Message +mkAlgAltMsg4 :: Type -> Id -> MsgDoc mkAlgAltMsg4 ty arg = vcat [ text "In some algebraic case alternative, type of argument doesn't match data constructor:", @@ -528,7 +528,7 @@ mkAlgAltMsg4 ty arg ppr arg ] -_mkRhsMsg :: Id -> Type -> Message +_mkRhsMsg :: Id -> Type -> MsgDoc _mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), ppr binder], diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index e2fb0c8540..defec7516b 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -3,88 +3,80 @@ % \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} -This data type represents programs just before code generation -(conversion to @AbstractC@): basically, what we have is a stylised -form of @CoreSyntax@, the style being one that happens to be ideally -suited to spineless tagless code generation. +This data type represents programs just before code generation (conversion to +@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style +being one that happens to be ideally suited to spineless tagless code +generation. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module StgSyn ( - GenStgArg(..), - GenStgLiveVars, + GenStgArg(..), + GenStgLiveVars, - GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgAlt, AltType(..), + GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgAlt, AltType(..), - UpdateFlag(..), isUpdatable, + UpdateFlag(..), isUpdatable, - StgBinderInfo, - noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, - combineStgBinderInfo, + StgBinderInfo, + noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, + combineStgBinderInfo, - -- a set of synonyms for the most common (only :-) parameterisation - StgArg, StgLiveVars, - StgBinding, StgExpr, StgRhs, StgAlt, + -- a set of synonyms for the most common (only :-) parameterisation + StgArg, StgLiveVars, + StgBinding, StgExpr, StgRhs, StgAlt, - -- StgOp - StgOp(..), + -- StgOp + StgOp(..), - -- SRTs - SRT(..), + -- SRTs + SRT(..), - -- utils - stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, - isDllConApp, isStgTypeArg, - stgArgType, + -- utils + stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + isDllConApp, isStgTypeArg, + stgArgType, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs - - , pprStgLVs + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, + pprStgLVs ) where #include "HsVersions.h" -import CostCentre ( CostCentreStack, CostCentre ) -import VarSet ( IdSet, isEmptyVarSet ) -import Id -import DataCon -import IdInfo ( mayHaveCafRefs ) -import Literal ( Literal, literalType ) -import ForeignCall ( ForeignCall ) -import CoreSyn ( AltCon ) -import PprCore ( {- instances -} ) -import PrimOp ( PrimOp, PrimCall ) -import Outputable -import Type ( Type ) -import TyCon ( TyCon ) -import UniqSet -import Unique ( Unique ) import Bitmap +import CoreSyn ( AltCon ) +import CostCentre ( CostCentreStack, CostCentre ) +import DataCon import DynFlags -import Platform -import StaticFlags ( opt_SccProfilingOn ) -import Module import FastString - -import Packages ( isDllName ) -import Type ( typePrimRep ) -import TyCon ( PrimRep(..) ) +import ForeignCall ( ForeignCall ) +import Id +import IdInfo ( mayHaveCafRefs ) +import Literal ( Literal, literalType ) +import Module +import Outputable +import Packages ( isDllName ) +import Platform +import PprCore ( {- instances -} ) +import PrimOp ( PrimOp, PrimCall ) +import StaticFlags ( opt_SccProfilingOn ) +import TyCon ( PrimRep(..) ) +import TyCon ( TyCon ) +import Type ( Type ) +import Type ( typePrimRep ) +import UniqSet +import Unique ( Unique ) +import VarSet ( IdSet, isEmptyVarSet ) \end{code} %************************************************************************ -%* * +%* * \subsection{@GenStgBinding@} -%* * +%* * %************************************************************************ -As usual, expressions are interesting; other things are boring. Here +As usual, expressions are interesting; other things are boring. Here are the boring things [except note the @GenStgRhs@], parameterised with respect to binder and occurrence information (just as in @CoreSyn@): @@ -93,32 +85,30 @@ There is one SRT for each group of bindings. \begin{code} data GenStgBinding bndr occ - = StgNonRec bndr (GenStgRhs bndr occ) - | StgRec [(bndr, GenStgRhs bndr occ)] + = StgNonRec bndr (GenStgRhs bndr occ) + | StgRec [(bndr, GenStgRhs bndr occ)] \end{code} %************************************************************************ -%* * +%* * \subsection{@GenStgArg@} -%* * +%* * %************************************************************************ \begin{code} data GenStgArg occ - = StgVarArg occ - | StgLitArg Literal - | StgTypeArg Type -- For when we want to preserve all type info -\end{code} + = StgVarArg occ + | StgLitArg Literal + | StgTypeArg Type -- For when we want to preserve all type info -\begin{code} isStgTypeArg :: StgArg -> Bool isStgTypeArg (StgTypeArg _) = True isStgTypeArg _ = False -isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool --- Does this constructor application refer to +-- | Does this constructor application refer to -- anything in a different *Windows* DLL? -- If so, we can't allocate it statically +isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool isDllConApp dflags con args | platformOS (targetPlatform dflags) == OSMinGW32 = isDllName this_pkg (dataConName con) || any is_dll_arg args @@ -131,11 +121,10 @@ isDllConApp dflags con args this_pkg = thisPackage dflags -isAddrRep :: PrimRep -> Bool -- True of machine adddresses; these are the things that don't --- work across DLLs. --- The key point here is that VoidRep comes out False, so that --- a top level nullary GADT construtor is False for isDllConApp +-- work across DLLs. The key point here is that VoidRep comes +-- out False, so that a top level nullary GADT construtor is +-- False for isDllConApp -- data T a where -- T1 :: T Int -- gives @@ -144,35 +133,38 @@ isAddrRep :: PrimRep -> Bool -- $WT1 :: T Int -- $WT1 = T1 Int (Coercion (Refl Int)) -- The coercion argument here gets VoidRep +isAddrRep :: PrimRep -> Bool isAddrRep AddrRep = True isAddrRep PtrRep = True isAddrRep _ = False +-- | Type of an @StgArg@ +-- +-- Very half baked becase we have lost the type arguments. stgArgType :: StgArg -> Type - -- Very half baked becase we have lost the type arguments stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit stgArgType (StgTypeArg _) = panic "stgArgType called on stgTypeArg" \end{code} %************************************************************************ -%* * +%* * \subsection{STG expressions} -%* * +%* * %************************************************************************ The @GenStgExpr@ data type is parameterised on binder and occurrence info, as before. %************************************************************************ -%* * +%* * \subsubsection{@GenStgExpr@ application} -%* * +%* * %************************************************************************ An application is of a function to a list of atoms [not expressions]. Operationally, we want to push the arguments on the stack and call the -function. (If the arguments were expressions, we would have to build +function. (If the arguments were expressions, we would have to build their closures first.) There is no constructor for a lone variable; it would appear as @@ -182,87 +174,91 @@ type GenStgLiveVars occ = UniqSet occ data GenStgExpr bndr occ = StgApp - occ -- function - [GenStgArg occ] -- arguments; may be empty + occ -- function + [GenStgArg occ] -- arguments; may be empty \end{code} %************************************************************************ -%* * +%* * \subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications} -%* * +%* * %************************************************************************ -There are a specialised forms of application, for -constructors, primitives, and literals. +There are a specialised forms of application, for constructors, +primitives, and literals. \begin{code} - | StgLit Literal - - -- StgConApp is vital for returning unboxed tuples - -- which can't be let-bound first - | StgConApp DataCon - [GenStgArg occ] -- Saturated - - | StgOpApp StgOp -- Primitive op or foreign call - [GenStgArg occ] -- Saturated - Type -- Result type - -- We need to know this so that we can - -- assign result registers + | StgLit Literal + + -- StgConApp is vital for returning unboxed tuples + -- which can't be let-bound first + | StgConApp DataCon + [GenStgArg occ] -- Saturated + + | StgOpApp StgOp -- Primitive op or foreign call + [GenStgArg occ] -- Saturated + Type -- Result type + -- We need to know this so that we can + -- assign result registers \end{code} %************************************************************************ -%* * +%* * \subsubsection{@StgLam@} -%* * +%* * %************************************************************************ -StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished -it encodes (\x -> e) as (let f = \x -> e in f) +StgLam is used *only* during CoreToStg's work. Before CoreToStg has +finished it encodes (\x -> e) as (let f = \x -> e in f) \begin{code} | StgLam - Type -- Type of whole lambda (useful when making a binder for it) - [bndr] - StgExpr -- Body of lambda + Type -- Type of whole lambda (useful when + -- making a binder for it) + [bndr] + StgExpr -- Body of lambda \end{code} %************************************************************************ -%* * +%* * \subsubsection{@GenStgExpr@: case-expressions} -%* * +%* * %************************************************************************ This has the same boxed/unboxed business as Core case expressions. \begin{code} | StgCase - (GenStgExpr bndr occ) - -- the thing to examine + (GenStgExpr bndr occ) + -- the thing to examine - (GenStgLiveVars occ) -- Live vars of whole case expression, - -- plus everything that happens after the case - -- i.e., those which mustn't be overwritten + (GenStgLiveVars occ) + -- Live vars of whole case expression, + -- plus everything that happens after the case + -- i.e., those which mustn't be overwritten - (GenStgLiveVars occ) -- Live vars of RHSs (plus what happens afterwards) - -- i.e., those which must be saved before eval. - -- - -- note that an alt's constructor's - -- binder-variables are NOT counted in the - -- free vars for the alt's RHS + (GenStgLiveVars occ) + -- Live vars of RHSs (plus what happens afterwards) + -- i.e., those which must be saved before eval. + -- + -- note that an alt's constructor's + -- binder-variables are NOT counted in the + -- free vars for the alt's RHS - bndr -- binds the result of evaluating the scrutinee + bndr -- binds the result of evaluating the scrutinee - SRT -- The SRT for the continuation + SRT -- The SRT for the continuation - AltType + AltType - [GenStgAlt bndr occ] -- The DEFAULT case is always *first* - -- if it is there at all + [GenStgAlt bndr occ] + -- The DEFAULT case is always *first* + -- if it is there at all \end{code} %************************************************************************ -%* * -\subsubsection{@GenStgExpr@: @let(rec)@-expressions} -%* * +%* * +\subsubsection{@GenStgExpr@: @let(rec)@-expressions} +%* * %************************************************************************ The various forms of let(rec)-expression encode most of the @@ -270,7 +266,7 @@ interesting things we want to do. \begin{enumerate} \item \begin{verbatim} -let-closure x = [free-vars] expr [args] +let-closure x = [free-vars] [args] expr in e \end{verbatim} is equivalent to @@ -310,13 +306,14 @@ distinguish between them with an @is_recursive@ boolean flag. let-unboxed u = an arbitrary arithmetic expression in unboxed values in e \end{verbatim} -All the stuff on the RHS must be fully evaluated. No function calls either! +All the stuff on the RHS must be fully evaluated. +No function calls either! (We've backed away from this toward case-expressions with suitably-magical alts ...) \item -~[Advanced stuff here! Not to start with, but makes pattern matching +~[Advanced stuff here! Not to start with, but makes pattern matching generate more efficient code.] \begin{verbatim} @@ -324,7 +321,7 @@ let-escapes-not fail = expr in e' \end{verbatim} Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, -or pass it to another function. All @e'@ will ever do is tail-call @fail@. +or pass it to another function. All @e'@ will ever do is tail-call @fail@. Rather than build a closure for @fail@, all we need do is to record the stack level at the moment of the @let-escapes-not@; then entering @fail@ is just a matter of adjusting the stack pointer back down to that point and entering @@ -333,9 +330,9 @@ the code for it. Another example: \begin{verbatim} f x y = let z = huge-expression in - if y==1 then z else - if y==2 then z else - 1 + if y==1 then z else + if y==2 then z else + 1 \end{verbatim} (A let-escapes-not is an @StgLetNoEscape@.) @@ -346,66 +343,65 @@ We may eventually want: let-literal x = Literal in e \end{verbatim} - -(ToDo: is this obsolete?) \end{enumerate} And so the code for let(rec)-things: \begin{code} | StgLet - (GenStgBinding bndr occ) -- right hand sides (see below) - (GenStgExpr bndr occ) -- body + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body - | StgLetNoEscape -- remember: ``advanced stuff'' - (GenStgLiveVars occ) -- Live in the whole let-expression - -- Mustn't overwrite these stack slots - -- *Doesn't* include binders of the let(rec). + | StgLetNoEscape -- remember: ``advanced stuff'' + (GenStgLiveVars occ) -- Live in the whole let-expression + -- Mustn't overwrite these stack slots + -- _Doesn't_ include binders of the let(rec). - (GenStgLiveVars occ) -- Live in the right hand sides (only) - -- These are the ones which must be saved on - -- the stack if they aren't there already - -- *Does* include binders of the let(rec) if recursive. + (GenStgLiveVars occ) -- Live in the right hand sides (only) + -- These are the ones which must be saved on + -- the stack if they aren't there already + -- _Does_ include binders of the let(rec) if recursive. - (GenStgBinding bndr occ) -- right hand sides (see below) - (GenStgExpr bndr occ) -- body + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body \end{code} %************************************************************************ -%* * +%* * \subsubsection{@GenStgExpr@: @scc@ expressions} -%* * +%* * %************************************************************************ -Finally for @scc@ expressions we introduce a new STG construct. +For @scc@ expressions we introduce a new STG construct. \begin{code} | StgSCC - CostCentre -- label of SCC expression - !Bool -- bump the entry count? - !Bool -- push the cost centre? - (GenStgExpr bndr occ) -- scc expression + CostCentre -- label of SCC expression + !Bool -- bump the entry count? + !Bool -- push the cost centre? + (GenStgExpr bndr occ) -- scc expression \end{code} %************************************************************************ -%* * +%* * \subsubsection{@GenStgExpr@: @hpc@ expressions} -%* * +%* * %************************************************************************ Finally for @scc@ expressions we introduce a new STG construct. \begin{code} | StgTick - Module -- the module of the source of this tick - Int -- tick number - (GenStgExpr bndr occ) -- sub expression - -- end of GenStgExpr + Module -- the module of the source of this tick + Int -- tick number + (GenStgExpr bndr occ) -- sub expression + +-- END of GenStgExpr \end{code} %************************************************************************ -%* * +%* * \subsection{STG right-hand sides} -%* * +%* * %************************************************************************ Here's the rest of the interesting stuff for @StgLet@s; the first @@ -413,15 +409,15 @@ flavour is for closures: \begin{code} data GenStgRhs bndr occ = StgRhsClosure - CostCentreStack -- CCS to be attached (default is CurrentCCS) - StgBinderInfo -- Info about how this binder is used (see below) - [occ] -- non-global free vars; a list, rather than - -- a set, because order is important - !UpdateFlag -- ReEntrant | Updatable | SingleEntry - SRT -- The SRT reference - [bndr] -- arguments; if empty, then not a function; - -- as above, order is important. - (GenStgExpr bndr occ) -- body + CostCentreStack -- CCS to be attached (default is CurrentCCS) + StgBinderInfo -- Info about how this binder is used (see below) + [occ] -- non-global free vars; a list, rather than + -- a set, because order is important + !UpdateFlag -- ReEntrant | Updatable | SingleEntry + SRT -- The SRT reference + [bndr] -- arguments; if empty, then not a function; + -- as above, order is important. + (GenStgExpr bndr occ) -- body \end{code} An example may be in order. Consider: \begin{verbatim} @@ -438,30 +434,26 @@ will be exactly that in parentheses above. The second flavour of right-hand-side is for constructors (simple but important): \begin{code} | StgRhsCon - CostCentreStack -- CCS to be attached (default is CurrentCCS). - -- Top-level (static) ones will end up with - -- DontCareCCS, because we don't count static - -- data in heap profiles, and we don't set CCCS - -- from static closure. - DataCon -- constructor - [GenStgArg occ] -- args -\end{code} + CostCentreStack -- CCS to be attached (default is CurrentCCS). + -- Top-level (static) ones will end up with + -- DontCareCCS, because we don't count static + -- data in heap profiles, and we don't set CCCS + -- from static closure. + DataCon -- constructor + [GenStgArg occ] -- args -\begin{code} stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) +stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = ASSERT( all isId bndrs ) length bndrs -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon _ _ _) = 0 -\end{code} -\begin{code} stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) rhsHasCafRefs :: GenStgRhs bndr Id -> Bool -rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) +rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) = isUpdatable upd || nonEmptySRT srt rhsHasCafRefs (StgRhsCon _ _ args) = any stgArgHasCafRefs args @@ -475,10 +467,10 @@ Here's the @StgBinderInfo@ type, and its combining op: \begin{code} data StgBinderInfo = NoStgBinderInfo - | SatCallsOnly -- All occurrences are *saturated* *function* calls - -- This means we don't need to build an info table and - -- slow entry code for the thing - -- Thunks never get this value + | SatCallsOnly -- All occurrences are *saturated* *function* calls + -- This means we don't need to build an info table and + -- slow entry code for the thing + -- Thunks never get this value noBinderInfo, stgUnsatOcc, stgSatOcc :: StgBinderInfo noBinderInfo = NoStgBinderInfo @@ -500,54 +492,54 @@ pp_binder_info SatCallsOnly = ptext (sLit "sat-only") \end{code} %************************************************************************ -%* * +%* * \subsection[Stg-case-alternatives]{STG case alternatives} -%* * +%* * %************************************************************************ Very like in @CoreSyntax@ (except no type-world stuff). The type constructor is guaranteed not to be abstract; that is, we can -see its representation. This is important because the code generator -uses it to determine return conventions etc. But it's not trivial +see its representation. This is important because the code generator +uses it to determine return conventions etc. But it's not trivial where there's a moduule loop involved, because some versions of a type -constructor might not have all the constructors visible. So +constructor might not have all the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the constructors or literals (which are guaranteed to have the Real McCoy) rather than from the scrutinee type. \begin{code} type GenStgAlt bndr occ - = (AltCon, -- alts: data constructor, - [bndr], -- constructor's parameters, - [Bool], -- "use mask", same length as - -- parameters; a True in a - -- param's position if it is - -- used in the ... - GenStgExpr bndr occ) -- ...right-hand side. + = (AltCon, -- alts: data constructor, + [bndr], -- constructor's parameters, + [Bool], -- "use mask", same length as + -- parameters; a True in a + -- param's position if it is + -- used in the ... + GenStgExpr bndr occ) -- ...right-hand side. data AltType - = PolyAlt -- Polymorphic (a type variable) - | UbxTupAlt TyCon -- Unboxed tuple - | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts - | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts + = PolyAlt -- Polymorphic (a type variable) + | UbxTupAlt TyCon -- Unboxed tuple + | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts + | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts \end{code} %************************************************************************ -%* * +%* * \subsection[Stg]{The Plain STG parameterisation} -%* * +%* * %************************************************************************ This happens to be the only one we use at the moment. \begin{code} -type StgBinding = GenStgBinding Id Id -type StgArg = GenStgArg Id -type StgLiveVars = GenStgLiveVars Id -type StgExpr = GenStgExpr Id Id -type StgRhs = GenStgRhs Id Id -type StgAlt = GenStgAlt Id Id +type StgBinding = GenStgBinding Id Id +type StgArg = GenStgArg Id +type StgLiveVars = GenStgLiveVars Id +type StgExpr = GenStgExpr Id Id +type StgRhs = GenStgRhs Id Id +type StgAlt = GenStgAlt Id Id \end{code} %************************************************************************ @@ -559,8 +551,8 @@ type StgAlt = GenStgAlt Id Id This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. A @ReEntrant@ closure may be entered multiple times, but should not be -updated or blackholed. An @Updatable@ closure should be updated after -evaluation (and may be blackholed during evaluation). A @SingleEntry@ +updated or blackholed. An @Updatable@ closure should be updated after +evaluation (and may be blackholed during evaluation). A @SingleEntry@ closure will only be entered once, and so need not be updated but may safely be blackholed. @@ -568,8 +560,10 @@ safely be blackholed. data UpdateFlag = ReEntrant | Updatable | SingleEntry instance Outputable UpdateFlag where - ppr u - = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) + ppr u = char $ case u of + ReEntrant -> 'r' + Updatable -> 'u' + SingleEntry -> 's' isUpdatable :: UpdateFlag -> Bool isUpdatable ReEntrant = False @@ -588,14 +582,15 @@ It's quite useful to move these around together, notably in StgOpApp and COpStmt. \begin{code} -data StgOp = StgPrimOp PrimOp +data StgOp + = StgPrimOp PrimOp - | StgPrimCallOp PrimCall + | StgPrimCallOp PrimCall - | StgFCallOp ForeignCall Unique - -- The Unique is occasionally needed by the C pretty-printer - -- (which lacks a unique supply), notably when generating a - -- typedef for foreign-export-dynamic + | StgFCallOp ForeignCall Unique + -- The Unique is occasionally needed by the C pretty-printer + -- (which lacks a unique supply), notably when generating a + -- typedef for foreign-export-dynamic \end{code} @@ -605,19 +600,20 @@ data StgOp = StgPrimOp PrimOp %* * %************************************************************************ -There is one SRT per top-level function group. Each local binding and +There is one SRT per top-level function group. Each local binding and case expression within this binding group has a subrange of the whole SRT, expressed as an offset and length. -In CoreToStg we collect the list of CafRefs at each SRT site, which is later +In CoreToStg we collect the list of CafRefs at each SRT site, which is later converted into the length and offset form by the SRT pass. \begin{code} -data SRT = NoSRT - | SRTEntries IdSet - -- generated by CoreToStg - | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-} - -- generated by computeSRTs +data SRT + = NoSRT + | SRTEntries IdSet + -- generated by CoreToStg + | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-} + -- generated by computeSRTs nonEmptySRT :: SRT -> Bool nonEmptySRT NoSRT = False @@ -631,9 +627,9 @@ pprSRT (SRT off _ _) = parens (ppr off <> comma <> text "*bitmap*") \end{code} %************************************************************************ -%* * +%* * \subsection[Stg-pretty-printing]{Pretty-printing} -%* * +%* * %************************************************************************ Robin Popplestone asked for semi-colon separators on STG binds; here's @@ -641,77 +637,65 @@ hoping he likes terminators instead... Ditto for case alternatives. \begin{code} pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) - => GenStgBinding bndr bdee -> SDoc + => GenStgBinding bndr bdee -> SDoc pprGenStgBinding (StgNonRec bndr rhs) = hang (hsep [ppr bndr, equals]) - 4 ((<>) (ppr rhs) semi) + 4 ((<>) (ppr rhs) semi) pprGenStgBinding (StgRec pairs) - = vcat ((ifPprDebug (ptext (sLit "{- StgRec (begin) -}"))) : - (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext (sLit "{- StgRec (end) -}")))]) + = vcat $ ifPprDebug (ptext $ sLit "{- StgRec (begin) -}") : + map (ppr_bind) pairs ++ [ifPprDebug $ ptext $ sLit "{- StgRec (end) -}"] where ppr_bind (bndr, expr) = hang (hsep [ppr bndr, equals]) - 4 ((<>) (ppr expr) semi) + 4 ((<>) (ppr expr) semi) -pprStgBinding :: StgBinding -> SDoc +pprStgBinding :: StgBinding -> SDoc pprStgBinding bind = pprGenStgBinding bind pprStgBindings :: [StgBinding] -> SDoc pprStgBindings binds = vcat (map pprGenStgBinding binds) -pprGenStgBindingWithSRT - :: (Outputable bndr, Outputable bdee, Ord bdee) - => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc - +pprGenStgBindingWithSRT :: (Outputable bndr, Outputable bdee, Ord bdee) + => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc pprGenStgBindingWithSRT (bind,srts) - = vcat (pprGenStgBinding bind : map pprSRT srts) - where pprSRT (id,srt) = - ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt + = vcat $ pprGenStgBinding bind : map pprSRT srts + where pprSRT (id,srt) = + ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) -\end{code} -\begin{code} instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgBinding bndr bdee) where + => Outputable (GenStgBinding bndr bdee) where ppr = pprGenStgBinding instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgExpr bndr bdee) where + => Outputable (GenStgExpr bndr bdee) where ppr = pprStgExpr instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (GenStgRhs bndr bdee) where + => Outputable (GenStgRhs bndr bdee) where ppr rhs = pprStgRhs rhs -\end{code} -\begin{code} pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc - pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty -\end{code} -\begin{code} pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) - => GenStgExpr bndr bdee -> SDoc + => GenStgExpr bndr bdee -> SDoc -- special case pprStgExpr (StgLit lit) = ppr lit -- general case pprStgExpr (StgApp func args) - = hang (ppr func) - 4 (sep (map (ppr) args)) -\end{code} + = hang (ppr func) 4 (sep (map (ppr) args)) -\begin{code} pprStgExpr (StgConApp con args) = hsep [ ppr con, brackets (interppSP args)] @@ -720,29 +704,27 @@ pprStgExpr (StgOpApp op args _) pprStgExpr (StgLam _ bndrs body) =sep [ char '\\' <+> ppr bndrs <+> ptext (sLit "->"), - pprStgExpr body ] -\end{code} + pprStgExpr body ] -\begin{code} -- special case: let v = <very specific thing> --- in --- let ... --- in --- ... +-- in +-- let ... +-- in +-- ... -- -- Very special! Suspicious! (SLPJ) {- pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) - expr@(StgLet _ _)) + expr@(StgLet _ _)) = ($$) (hang (hcat [ptext (sLit "let { "), ppr bndr, ptext (sLit " = "), - ppr cc, - pp_binder_info bi, - ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), - ppr upd_flag, ptext (sLit " ["), - interppSP args, char ']']) - 8 (sep [hsep [ppr rhs, ptext (sLit "} in")]])) + ppr cc, + pp_binder_info bi, + ptext (sLit " ["), ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), + ppr upd_flag, ptext (sLit " ["), + interppSP args, char ']']) + 8 (sep [hsep [ppr rhs, ptext (sLit "} in")]])) (ppr expr) -} @@ -751,24 +733,24 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a pprStgExpr (StgLet bind expr@(StgLet _ _)) = ($$) (sep [hang (ptext (sLit "let {")) - 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])]) + 2 (hsep [pprGenStgBinding bind, ptext (sLit "} in")])]) (ppr expr) -- general case pprStgExpr (StgLet bind expr) = sep [hang (ptext (sLit "let {")) 2 (pprGenStgBinding bind), - hang (ptext (sLit "} in ")) 2 (ppr expr)] + hang (ptext (sLit "} in ")) 2 (ppr expr)] pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) = sep [hang (ptext (sLit "let-no-escape {")) - 2 (pprGenStgBinding bind), - hang ((<>) (ptext (sLit "} in ")) - (ifPprDebug ( - nest 4 ( - hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), - ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), - char ']'])))) - 2 (ppr expr)] + 2 (pprGenStgBinding bind), + hang ((<>) (ptext (sLit "} in ")) + (ifPprDebug ( + nest 4 ( + hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + char ']'])))) + 2 (ppr expr)] pprStgExpr (StgSCC cc tick push expr) = sep [ hsep [scc, ppr cc], pprStgExpr expr ] @@ -779,27 +761,27 @@ pprStgExpr (StgSCC cc tick push expr) pprStgExpr (StgTick m n expr) = sep [ hsep [ptext (sLit "_tick_"), pprModule m,text (show n)], - pprStgExpr expr ] + pprStgExpr expr ] pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) = sep [sep [ptext (sLit "case"), - nest 4 (hsep [pprStgExpr expr, - ifPprDebug (dcolon <+> ppr alt_type)]), - ptext (sLit "of"), ppr bndr, char '{'], - ifPprDebug ( - nest 4 ( - hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), - ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), - ptext (sLit "]; "), - pprMaybeSRT srt])), - nest 2 (vcat (map pprStgAlt alts)), - char '}'] + nest 4 (hsep [pprStgExpr expr, + ifPprDebug (dcolon <+> ppr alt_type)]), + ptext (sLit "of"), ppr bndr, char '{'], + ifPprDebug ( + nest 4 ( + hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext (sLit "]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + ptext (sLit "]; "), + pprMaybeSRT srt])), + nest 2 (vcat (map pprStgAlt alts)), + char '}'] pprStgAlt :: (Outputable bndr, Outputable occ, Ord occ) => GenStgAlt bndr occ -> SDoc pprStgAlt (con, params, _use_mask, expr) = hang (hsep [ppr con, interppSP params, ptext (sLit "->")]) - 4 (ppr expr <> semi) + 4 (ppr expr <> semi) pprStgOp :: StgOp -> SDoc pprStgOp (StgPrimOp op) = ppr op @@ -807,46 +789,43 @@ pprStgOp (StgPrimCallOp op)= ppr op pprStgOp (StgFCallOp op _) = ppr op instance Outputable AltType where - ppr PolyAlt = ptext (sLit "Polymorphic") + ppr PolyAlt = ptext (sLit "Polymorphic") ppr (UbxTupAlt tc) = ptext (sLit "UbxTup") <+> ppr tc ppr (AlgAlt tc) = ptext (sLit "Alg") <+> ppr tc ppr (PrimAlt tc) = ptext (sLit "Prim") <+> ppr tc -\end{code} -\begin{code} pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc pprStgLVs lvs = getPprStyle $ \ sty -> if userStyle sty || isEmptyUniqSet lvs then - empty + empty else - hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] -\end{code} + hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] -\begin{code} pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) - => GenStgRhs bndr bdee -> SDoc + => GenStgRhs bndr bdee -> SDoc -- special case pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func [])) = hcat [ ppr cc, - pp_binder_info bi, - brackets (ifPprDebug (ppr free_var)), - ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ] + pp_binder_info bi, + brackets (ifPprDebug (ppr free_var)), + ptext (sLit " \\"), ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ] -- general case pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) = hang (hsep [if opt_SccProfilingOn then ppr cc else empty, - pp_binder_info bi, - ifPprDebug (brackets (interppSP free_vars)), - char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) - 4 (ppr body) + pp_binder_info bi, + ifPprDebug (brackets (interppSP free_vars)), + char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) + 4 (ppr body) pprStgRhs (StgRhsCon cc con args) = hcat [ ppr cc, - space, ppr con, ptext (sLit "! "), brackets (interppSP args)] + space, ppr con, ptext (sLit "! "), brackets (interppSP args)] pprMaybeSRT :: SRT -> SDoc pprMaybeSRT (NoSRT) = empty pprMaybeSRT srt = ptext (sLit "srt:") <> pprSRT srt \end{code} + diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 614798873e..0bfd025410 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -265,17 +265,26 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) idDemandInfo case_bndr' (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut + res_ty = alt_ty1 `bothType` scrut_ty in - (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt']) +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty1 +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty [alt']) dmdAnal env dmd (Case scrut case_bndr ty alts) = let (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts (scrut_ty, scrut') = dmdAnal env evalDmd scrut (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr + res_ty = alt_ty `bothType` scrut_ty in --- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys) - (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts') +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty +-- , text "res_ty" <+> ppr res_ty ]) $ + (res_ty, Case scrut' case_bndr' ty alts') dmdAnal env dmd (Let (NonRec id rhs) body) = let @@ -337,7 +346,7 @@ dmdAnalAlt env dmd (con,bndrs,rhs) -- other -> return () -- So the 'y' isn't necessarily going to be evaluated -- - -- A more complete example where this shows up is: + -- A more complete example (Trac #148, #1592) where this shows up is: -- do { let len = <expensive> ; -- ; when (...) (exitWith ExitSuccess) -- ; print len } diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 0a94b2b5a7..c873c631da 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -21,13 +21,15 @@ import TypeRep import TcMType import TcRnMonad import TyCon +import DynFlags import Name import Module import SrcLoc import Outputable import UniqFM import FastString - +import VarSet ( varSetElems ) +import Util( filterOut ) import Maybes import Control.Monad import Data.Map (Map) @@ -91,7 +93,7 @@ listToSet l = Map.fromList (zip l (repeat ())) checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency famInstMods directlyImpMods - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; (eps, hpt) <- getEpsAndHpt ; let { -- Fetch the iface of a given module. Must succeed as @@ -166,7 +168,7 @@ then we have a coercion (ie, type instance of family instance coercion) which implies that :R42T was declared as 'data instance T [a]'. \begin{code} -tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type])) +tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (FamInst, [Type])) tcLookupFamInst tycon tys | not (isFamilyTyCon tycon) = return Nothing @@ -176,7 +178,7 @@ tcLookupFamInst tycon tys ; case lookupFamInstEnv instEnv tycon tys of [] -> return Nothing ((fam_inst, rep_tys):_) - -> return $ Just (famInstTyCon fam_inst, rep_tys) + -> return $ Just (fam_inst, rep_tys) } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) @@ -189,8 +191,9 @@ tcLookupDataFamInst tycon tys = ASSERT( isAlgTyCon tycon ) do { maybeFamInst <- tcLookupFamInst tycon tys ; case maybeFamInst of - Nothing -> famInstNotFound tycon tys - Just famInst -> return famInst } + Nothing -> famInstNotFound tycon tys + Just (famInst, tys) -> let tycon' = dataFamInstRepTyCon famInst + in return (tycon', tys) } famInstNotFound :: TyCon -> [Type] -> TcM a famInstNotFound tycon tys @@ -234,35 +237,44 @@ with standalone deriving declrations. tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv - ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts - ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, - tcg_fam_inst_env = inst_env' } + ; (inst_env', fam_insts') <- foldlM addLocalFamInst + (tcg_fam_inst_env env, tcg_fam_insts env) + fam_insts + ; let env' = env { tcg_fam_insts = fam_insts' + , tcg_fam_inst_env = inst_env' } ; setGblEnv env' thing_inside } -- Check that the proposed new instance is OK, -- and then add it to the home inst env -addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv -addLocalFamInst home_fie famInst = do - -- Load imported instances, so that we report - -- overlaps correctly - eps <- getEps - let inst_envs = (eps_fam_inst_env eps, home_fie) - - -- Check for conflicting instance decls - skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst)) - let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs - -- If there are any conflicts, we should probably error - -- But, if we're allowed to overwrite and the conflict is in the home FIE, - -- then overwrite instead of error. - traceTc "checkForConflicts" (ppr conflicts $$ ppr famInst $$ ppr inst_envs) - isGHCi <- getIsGHCi - case conflicts of - dup : _ -> case (isGHCi, home_conflicts) of - (True, _ : _) -> return (overwriteFamInstEnv home_fie famInst) - (_, _) -> conflictInstErr famInst (fst dup) >> return (extendFamInstEnv home_fie famInst) - where home_conflicts = lookupFamInstEnvConflicts' home_fie famInst skol_tvs - [] -> return (extendFamInstEnv home_fie famInst) +addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) +addLocalFamInst (home_fie, my_fis) fam_inst + -- home_fie includes home package and this module + -- my_fies is just the ones from this module + = do { isGHCi <- getIsGHCi + + -- In GHCi, we *override* any identical instances + -- that are also defined in the interactive context + ; let (home_fie', my_fis') + | isGHCi = (deleteFromFamInstEnv home_fie fam_inst, + filterOut (identicalFamInst fam_inst) my_fis) + | otherwise = (home_fie, my_fis) + + -- Load imported instances, so that we report + -- overlaps correctly + ; eps <- getEps + ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars fam_inst)) + ; let inst_envs = (eps_fam_inst_env eps, home_fie') + conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs + home_fie'' = extendFamInstEnv home_fie fam_inst + + -- Check for conflicting instance decls + ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) + ; case conflicts of + [] -> return (home_fie'', fam_inst : my_fis') + dup : _ -> do { conflictInstErr fam_inst (fst dup) + ; return (home_fie, my_fis) } + } \end{code} %************************************************************************ @@ -285,7 +297,7 @@ checkForConflicts inst_envs famInst -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst)) + ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst)) ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs ; unless (null conflicts) $ conflictInstErr famInst (fst (head conflicts)) diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 34f68182ec..a194d748ed 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -27,14 +27,12 @@ module Inst ( -- Simple functions over evidence variables hasEqualities, unitImplication, - tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX, + tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts, - tidyWantedEvVar, tidyWantedEvVars, tidyWC, - tidyEvVar, tidyImplication, tidyCt, + tidyEvVar, tidyCt, tidyGivenLoc, - substWantedEvVar, substWantedEvVars, substEvVar, substImplication, substCt ) where @@ -87,7 +85,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted origin pred = do { loc <- getCtLoc origin ; ev <- newWantedEvVar pred - ; emitFlat (mkEvVarX ev loc) + ; emitFlat (mkNonCanonical ev (Wanted loc)) ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) @@ -379,7 +377,7 @@ syntaxNameCtxt name orig ty tidy_env = do \begin{code} getOverlapFlag :: TcM OverlapFlag getOverlapFlag - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; let overlap_ok = xopt Opt_OverlappingInstances dflags incoherent_ok = xopt Opt_IncoherentInstances dflags safeOverlap = safeLanguageOn dflags @@ -395,7 +393,7 @@ tcGetInstEnvs :: TcM (InstEnv, InstEnv) tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; return (eps_inst_env eps, tcg_inst_env env) } -tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a +tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside = do { traceDFuns dfuns @@ -405,7 +403,7 @@ tcExtendLocalInstEnv dfuns thing_inside tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } -addLocalInst :: InstEnv -> Instance -> TcM InstEnv +addLocalInst :: InstEnv -> ClsInst -> TcM InstEnv -- Check that the proposed new instance is OK, -- and then add it to the home inst env -- If overwrite_inst, then we can overwrite a direct match @@ -468,30 +466,30 @@ addLocalInst home_ie ispec = do , let (_,_,_,dup_tys) = instanceHead dup_ispec , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] -traceDFuns :: [Instance] -> TcRn () +traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs = traceTc "Adding instances:" (vcat (map pp ispecs)) where pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec -- Print the dfun name itself too -funDepErr :: Instance -> [Instance] -> TcRn () +funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs = addDictLoc ispec $ addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:")) 2 (pprInstances (ispec:ispecs))) -dupInstErr :: Instance -> Instance -> TcRn () +dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec = addDictLoc ispec $ addErr (hang (ptext (sLit "Duplicate instance declarations:")) 2 (pprInstances [ispec, dup_ispec])) -overlappingInstErr :: Instance -> Instance -> TcRn () +overlappingInstErr :: ClsInst -> ClsInst -> TcRn () overlappingInstErr ispec dup_ispec = addDictLoc ispec $ addErr (hang (ptext (sLit "Overlapping instance declarations:")) 2 (pprInstances [ispec, dup_ispec])) -addDictLoc :: Instance -> TcRn a -> TcRn a +addDictLoc :: ClsInst -> TcRn a -> TcRn a addDictLoc ispec thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where @@ -550,13 +548,7 @@ tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) tyVarsOfImplication :: Implication -> TyVarSet tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted }) - = tyVarsOfWC wanted `minusVarSet` skols - -tyVarsOfEvVarX :: EvVarX a -> TyVarSet -tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev - -tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet -tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX + = tyVarsOfWC wanted `delVarSetList` skols tyVarsOfEvVar :: EvVar -> TyVarSet tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev @@ -576,34 +568,9 @@ tidyCt env ct , cc_flavor = tidyFlavor env (cc_flavor ct) , cc_depth = cc_depth ct } -tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints -tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = WC { wc_flat = mapBag (tidyCt env) flat - , wc_impl = mapBag (tidyImplication env) implic - , wc_insol = mapBag (tidyCt env) insol } - -tidyImplication :: TidyEnv -> Implication -> Implication -tidyImplication env implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted - , ic_loc = loc }) - = implic { ic_skols = mkVarSet tvs' - , ic_given = map (tidyEvVar env1) given - , ic_wanted = tidyWC env1 wanted - , ic_loc = tidyGivenLoc env1 loc } - where - (env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs) - tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar -tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l - -tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar -tidyWantedEvVars env = mapBag (tidyWantedEvVar env) - - tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk tidyFlavor _ fl = fl @@ -614,6 +581,14 @@ tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span c tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) + = UnifyForAllSkol (map tidy_tv skol_tvs) (tidyType env ty) + where + tidy_tv tv = case getTyVar_maybe ty' of + Just tv' -> tv' + Nothing -> pprPanic "ticySkolemInfo" (ppr tv <+> ppr ty') + where + ty' = tidyTyVarOcc env tv tidySkolemInfo _ info = info ---------------- Substitution ------------------------- @@ -641,23 +616,16 @@ substImplication subst implic@(Implic { ic_skols = tvs , ic_given = given , ic_wanted = wanted , ic_loc = loc }) - = implic { ic_skols = mkVarSet tvs' + = implic { ic_skols = tvs' , ic_given = map (substEvVar subst1) given , ic_wanted = substWC subst1 wanted , ic_loc = substGivenLoc subst1 loc } where - (subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs) + (subst1, tvs') = mapAccumL substTyVarBndr subst tvs substEvVar :: TvSubst -> EvVar -> EvVar substEvVar subst var = setVarType var (substTy subst (varType var)) -substWantedEvVars :: TvSubst -> Bag WantedEvVar -> Bag WantedEvVar -substWantedEvVars subst = mapBag (substWantedEvVar subst) - -substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar -substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l - - substFlavor :: TvSubst -> CtFlavor -> CtFlavor substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk substFlavor _ fl = fl diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index f58c566369..2934cda94b 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -348,25 +348,32 @@ tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames - , recS_rec_ids = recNames }) res_ty thing_inside - = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind - ; let rec_ids = zipWith mkLocalId recNames rec_tys - ; tcExtendIdEnv rec_ids $ do - { (stmts', (later_ids, rec_rets)) +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names }) res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + ; tcExtendIdEnv tup_ids $ do + { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> -- ToDo: res_ty not really right - do { rec_rets <- zipWithM tcCheckId recNames rec_tys - ; later_ids <- tcLookupLocalIds laterNames - ; return (later_ids, rec_rets) } + zipWithM tcCheckId tup_names tup_elt_tys - ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) + ; thing <- thing_inside res_ty -- NB: The rec_ids for the recursive things -- already scope over this part. This binding may shadow -- some of them with polymorphic things with the same Name -- (see note [RecStmt] in HsExpr) + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + + ; let rec_rets = takeList rec_names tup_rets + ; let ret_table = zip tup_ids tup_rets + ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] + ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_later_rets = later_rets , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets , recS_ret_ty = res_ty }, thing) }} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ac826b7507..e14bd49458 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -130,7 +130,7 @@ tcHsBootSigs (ValBindsOut binds sigs) tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) -badBootDeclErr :: Message +badBootDeclErr :: MsgDoc badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") ------------------------ @@ -332,7 +332,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list -- (as determined by sig_fn), returning a TcSigInfo for each ; tc_sig_fn <- tcInstSigs sig_fn binder_names - ; dflags <- getDOpts + ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env binder_names bind_list tc_sig_fn @@ -585,7 +585,8 @@ tcSpec poly_id prag@(SpecSig _ hs_ty inl) = addErrCtxt (spec_ctxt prag) $ do { spec_ty <- tcHsSigType sig_ctxt hs_ty ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) - (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id)) + (ptext (sLit "SPECIALISE pragma for non-overloaded function") + <+> quotes (ppr poly_id)) -- Note [SPECIALISE pragmas] ; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty ; return (SpecPrag poly_id wrap inl) } @@ -603,7 +604,7 @@ tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] -- SPECIALISE pragamas for imported things tcImpPrags prags = do { this_mod <- getModule - ; dflags <- getDOpts + ; dflags <- getDynFlags ; if (not_specialising dflags) then return [] else @@ -739,7 +740,7 @@ tcVect (HsVectInstOut _) vectCtxt :: Outputable thing => thing -> SDoc vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing -scalarTyConMustBeNullary :: Message +scalarTyConMustBeNullary :: MsgDoc scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary") -------------- diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index afd9093c52..426fbe7a68 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -8,9 +8,6 @@ module TcCanonical( canonicalize, - canOccursCheck, canEq, canEvVar, - rewriteWithFunDeps, - emitFDWorkAsWanted, emitFDWorkAsDerived, StopOrContinue (..) ) where @@ -19,8 +16,6 @@ module TcCanonical( import BasicTypes ( IPName ) import TcErrors import TcRnTypes -import FunDeps -import qualified TcMType as TcM import TcType import Type import Kind @@ -32,7 +27,7 @@ import Name ( Name ) import Var import VarEnv import Outputable -import Control.Monad ( when, unless, zipWithM, foldM ) +import Control.Monad ( when, unless, zipWithM ) import MonadUtils import Control.Applicative ( (<|>) ) @@ -42,7 +37,6 @@ import TcSMonad import FastString import Data.Maybe ( isNothing ) -import Pair ( pSnd ) \end{code} @@ -204,11 +198,13 @@ canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl canEvVar :: EvVar -> PredTree -> SubGoalDepth -> CtFlavor -> TcS StopOrContinue +-- Called only for non-canonical EvVars canEvVar ev pred_classifier d fl = case pred_classifier of ClassPred cls tys -> canClass d fl ev cls tys `andWhenContinue` emit_superclasses - EqPred ty1 ty2 -> canEq d fl ev ty1 ty2 + EqPred ty1 ty2 -> canEq d fl ev ty1 ty2 + `andWhenContinue` emit_kind_constraint IPPred nm ty -> canIP d fl ev nm ty IrredPred ev_ty -> canIrred d fl ev ev_ty TuplePred tys -> canTuple d fl ev tys @@ -219,9 +215,58 @@ canEvVar ev pred_classifier d fl = do { sctxt <- getTcSContext ; unless (simplEqsOnly sctxt) $ newSCWorkFromFlavored d v_new fl cls xis_new + -- Arguably we should "seq" the coercions if they are derived, + -- as we do below for emit_kind_constraint, to allow errors in + -- superclasses to be executed if deferred to runtime! ; continueWith ct } emit_superclasses _ = panic "emit_superclasses of non-class!" + emit_kind_constraint ct@(CTyEqCan { cc_id = ev, cc_depth = d + , cc_flavor = fl, cc_tyvar = tv + , cc_rhs = ty }) + = do_emit_kind_constraint ct ev d fl (mkTyVarTy tv) ty + + emit_kind_constraint ct@(CFunEqCan { cc_id = ev, cc_depth = d + , cc_flavor = fl + , cc_fun = fn, cc_tyargs = xis1 + , cc_rhs = xi2 }) + = do_emit_kind_constraint ct ev d fl (mkTyConApp fn xis1) xi2 + emit_kind_constraint ct = continueWith ct + + do_emit_kind_constraint ct eqv d fl ty1 ty2 + | compatKind k1 k2 = continueWith ct + | otherwise + = do { keqv <- forceNewEvVar kind_co_fl (mkEqPred (k1,k2)) + ; eqv' <- forceNewEvVar fl (mkEqPred (ty1,ty2)) + ; _fl <- case fl of + Wanted {}-> setEvBind eqv + (mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl + Given {} -> setEvBind eqv' + (mkEvKindCast eqv (mkTcCoVarCo keqv)) fl + Derived {} -> return fl + + ; canEq_ d kind_co_fl keqv k1 k2 -- Emit kind equality + ; continueWith (ct { cc_id = eqv' }) } + where k1 = typeKind ty1 + k2 = typeKind ty2 + ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 + -- Always create a Wanted kind equality even if + -- you are decomposing a given constraint. + -- NB: DV finds this reasonable for now. Maybe we + -- have to revisit. + kind_co_fl + | Given (CtLoc _sk_info src_span err_ctxt) _ <- fl + = let orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + ctloc = pushErrCtxtSameOrigin ctxt $ + CtLoc orig src_span err_ctxt + in Wanted ctloc + | Wanted ctloc <- fl + = Wanted (pushErrCtxtSameOrigin ctxt ctloc) + | Derived ctloc <- fl + = Derived (pushErrCtxtSameOrigin ctxt ctloc) + | otherwise + = panic "do_emit_kind_constraint: non-CtLoc inside!" + -- Tuple canonicalisation -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -555,26 +600,28 @@ flatten :: SubGoalDepth -- Depth flatten d ctxt ty | Just ty' <- tcView ty = do { (xi, co) <- flatten d ctxt ty' - ; return (xi,co) } - - -- DV: The following is tedious to do but maybe we should return to this - -- Preserve type synonyms if possible - -- ; if no_flattening - -- then return (xi, mkTcReflCo xi,no_flattening) -- Importantly, not xi! - -- else return (xi,co,no_flattening) - -- } - -flatten d ctxt v@(TyVarTy _) + ; return (xi,co) } + +flatten d ctxt (TyVarTy tv) = do { ieqs <- getInertEqs - ; let co = liftInertEqsTy ieqs ctxt v -- co : v ~ ty - ty = pSnd (tcCoercionKind co) - ; if v `eqType` ty then - return (ty,mkTcReflCo ty) - else -- NB recursive call. Why? See Note [Non-idempotent inert substitution] - -- Actually I believe that applying the substition only *twice* will suffice - - do { (ty_final,co') <- flatten d ctxt ty -- co' : ty_final ~ ty - ; return (ty_final,co' `mkTcTransCo` mkTcSymCo co) } } + ; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty + ; case mco of -- Done, but make sure the kind is zonked + Nothing -> + do { let knd = tyVarKind tv + ; (new_knd,_kind_co) <- flatten d ctxt knd + ; let ty = mkTyVarTy (setVarType tv new_knd) + ; return (ty, mkTcReflCo ty) } + -- NB recursive call. + -- Why? See Note [Non-idempotent inert substitution] + -- Actually, I think applying the substition just twice will suffice + Just (co,ty) -> + do { (ty_final,co') <- flatten d ctxt ty + ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } + where tv_eq_subst subst tv + | Just (ct,co) <- lookupVarEnv subst tv + , cc_flavor ct `canRewrite` ctxt + = Just (co,cc_rhs ct) + | otherwise = Nothing \end{code} @@ -689,7 +736,7 @@ flatten d ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. = do { let (tvs, rho) = splitForAllTys ty - ; when (under_families tvs rho) $ flattenForAllErrorTcS ctxt ty + ; when (under_families tvs rho) $ wrapErrTcS $ flattenForAllErrorTcS ctxt ty ; (rho', co) <- flatten d ctxt rho ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } @@ -771,26 +818,6 @@ canEq _d fl eqv ty1 ty2 do { _ <- setEqBind eqv (mkTcReflCo ty1) fl; return () } ; return Stop } --- Split up an equality between function types into two equalities. -canEq d fl eqv (FunTy s1 t1) (FunTy s2 t2) - = do { argeqv <- newEqVar fl s1 s2 - ; reseqv <- newEqVar fl t1 t2 - ; let argeqv_v = evc_the_evvar argeqv - reseqv_v = evc_the_evvar reseqv - ; (fl1,fl2) <- case fl of - Wanted {} -> - do { _ <- setEqBind eqv (mkTcFunCo (mkTcCoVarCo argeqv_v) (mkTcCoVarCo reseqv_v)) fl - ; return (fl,fl) } - Given {} -> - do { fl1 <- setEqBind argeqv_v (mkTcNthCo 0 (mkTcCoVarCo eqv)) fl - ; fl2 <- setEqBind reseqv_v (mkTcNthCo 1 (mkTcCoVarCo eqv)) fl - ; return (fl1,fl2) - } - Derived {} -> - return (fl,fl) - - ; canEqEvVarsCreated d [fl2,fl1] [reseqv,argeqv] [t1,s1] [t2,s2] } - -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ @@ -799,6 +826,11 @@ canEq d fl eqv ty1@(TyVarTy {}) ty2 canEq d fl eqv ty1 ty2@(TyVarTy {}) = canEqLeaf d fl eqv ty1 ty2 +-- See Note [Naked given applications] +canEq d fl eqv ty1 ty2 + | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 + | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' + canEq d fl eqv ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn = canEqLeaf d fl eqv ty1 ty2 @@ -806,14 +838,18 @@ canEq d fl eqv ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - , tc1 == tc2 - , length tys1 == length tys2 +canEq d fl eqv ty1 ty2 + | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 + , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 = -- Generate equalities for each of the corresponding arguments - do { let (kis1, tys1') = span isKind tys1 + if (tc1 /= tc2 || length tys1 /= length tys2) + -- Fail straight away for better error messages + then canEqFailure d fl eqv + else do { + let (kis1, tys1') = span isKind tys1 (_kis2, tys2') = span isKind tys2 - ; let kicos = map mkTcReflCo kis1 + kicos = map mkTcReflCo kis1 ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2' ; fls <- case fl of @@ -831,16 +867,32 @@ canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify -canEq d fl eqv ty1 ty2 - | Nothing <- tcView ty1 -- Naked applications ONLY - , Nothing <- tcView ty2 -- See Note [Naked given applications] - , Just (s1,t1) <- tcSplitAppTy_maybe ty1 +canEq d fl eqv ty1 ty2 -- e.g. F a b ~ Maybe c + -- where F has arity 1 + | Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 + = canEqAppTy d fl eqv s1 t1 s2 t2 + +canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) + | tcIsForAllTy s1, tcIsForAllTy s2, + Wanted {} <- fl + = canEqFailure d fl eqv + | otherwise + = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) + ; return Stop } + +canEq d fl eqv _ _ = canEqFailure d fl eqv + +-- Type application +canEqAppTy :: SubGoalDepth + -> CtFlavor -> EqVar -> Type -> Type -> Type -> Type + -> TcS StopOrContinue +canEqAppTy d fl eqv s1 t1 s2 t2 = ASSERT( not (isKind t1) && not (isKind t2) ) if isGivenOrSolved fl then - do { traceTcS "canEq/(app case)" $ + do { traceTcS "canEq (app case)" $ text "Ommitting decomposition of given equality between: " - <+> ppr ty1 <+> text "and" <+> ppr ty2 + <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2) -- We cannot decompose given applications -- because we no longer have 'left' and 'right' ; return Stop } @@ -856,25 +908,30 @@ canEq d fl eqv ty1 ty2 ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] } - -canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) - | tcIsForAllTy s1, tcIsForAllTy s2, - Wanted {} <- fl - = canEqFailure d fl eqv - | otherwise - = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) - ; return Stop } - --- Finally expand any type synonym applications. -canEq d fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 -canEq d fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' -canEq d fl eqv _ _ = canEqFailure d fl eqv - canEqFailure :: SubGoalDepth -> CtFlavor -> EvVar -> TcS StopOrContinue -canEqFailure d fl eqv = do { emitFrozenError fl eqv d; return Stop } +canEqFailure d fl eqv + = do { when (isWanted fl) (delCachedEvVar eqv fl) + -- See Note [Combining insoluble constraints] + ; emitFrozenError fl eqv d + ; return Stop } \end{code} +Note [Combining insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As this point we have an insoluble constraint, like Int~Bool. + + * If it is Wanted, delete it from the cache, so that subsequent + Int~Bool constraints give rise to separate error messages + + * But if it is Derived, DO NOT delete from cache. A class constraint + may get kicked out of the inert set, and then have its functional + dependency Derived constraints generated a second time. In that + case we don't want to get two (or more) error messages by + generating two (or more) insoluble fundep constraints from the same + class constraint. + + Note [Naked given applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: @@ -1106,28 +1163,17 @@ canEqLeafOriented :: SubGoalDepth -- Depth -> TcType -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application canEqLeafOriented d fl eqv s1 s2 - | let k1 = typeKind s1 - , let k2 = typeKind s2 - -- Establish kind invariants for CFunEqCan and CTyEqCan - = do { are_compat <- compatKindTcS k1 k2 - ; can_unify <- if not are_compat - then unifyKindTcS s1 s2 k1 k2 - else return False - -- If the kinds cannot be unified or are not compatible, don't fail - -- right away; instead, emit a frozen error - ; if (not are_compat && not can_unify) then - canEqFailure d fl eqv - else can_eq_kinds_ok d fl eqv s1 s2 } - - where can_eq_kinds_ok d fl eqv s1 s2 + = can_eq_split_lhs d fl eqv s1 s2 + where can_eq_split_lhs d fl eqv s1 s2 | Just (fn,tys1) <- splitTyConApp_maybe s1 = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2 | Just tv <- getTyVar_maybe s1 = canEqLeafTyVarLeftRec d fl eqv tv s2 | otherwise = pprPanic "canEqLeafOriented" $ - text "Non-variable or non-family equality LHS" <+> ppr eqv <+> - dcolon <+> ppr (evVarPred eqv) + text "Non-variable or non-family equality LHS" <+> + ppr eqv <+> dcolon <+> ppr (evVarPred eqv) + canEqLeafFunEqLeftRec :: SubGoalDepth -> CtFlavor -> EqVar @@ -1471,117 +1517,3 @@ we first try expanding each of the ti to types which no longer contain a. If this turns out to be impossible, we next try expanding F itself, and so on. - -%************************************************************************ -%* * -%* Functional dependencies, instantiation of equations -%* * -%************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see Trac #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of FunDeps.lhs (nicer -now!). - -\begin{code} -rewriteWithFunDeps :: [Equation] - -> [Xi] - -> WantedLoc - -> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)])) - -- Not quite a WantedEvVar unfortunately - -- Because our intention could be to make - -- it derived at the end of the day --- NB: The flavor of the returned EvVars will be decided by the caller --- Post: returns no trivial equalities (identities) and all EvVars returned are fresh -rewriteWithFunDeps eqn_pred_locs xis wloc - = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs - ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))] - fd_ev_pos = concat fd_ev_poss - (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) - ; if null fd_ev_pos then return Nothing - else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) } - -instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] --- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs - , fd_pred1 = d1, fd_pred2 = d2 }) - = do { let tvs = varSetElems qtvs - ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') - ; foldM (do_one subst) [] eqs } - where - do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) - = let sty1 = Type.substTy subst ty1 - sty2 = Type.substTy subst ty2 - in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds - ; let wl' = push_ctx wl - ; if isNewEvVar eqv then - return $ (i,(evc_the_evvar eqv,wl')):ievs - else -- We are eventually going to emit FD work back in the work list so - -- it is important that we only return the /freshly created/ and not - -- some existing equality! - return ievs } - - push_ctx :: WantedLoc -> WantedLoc - push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc - -mkEqnMsg :: (TcPredType, SDoc) - -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) -mkEqnMsg (pred1,from1) (pred2,from2) tidy_env - = do { zpred1 <- TcM.zonkTcPredType pred1 - ; zpred2 <- TcM.zonkTcPredType pred2 - ; let { tpred1 = tidyType tidy_env zpred1 - ; tpred2 = tidyType tidy_env zpred2 } - ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), - nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), - nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] - ; return (tidy_env, msg) } - -rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) - -> [Type] -- A sequence of types: tys - -> [(Type, TcCoercion)] -- Returns: [(ty', co : ty' ~ ty)] -rewriteDictParams param_eqs tys - = zipWith do_one tys [0..] - where - do_one :: Type -> Int -> (Type, TcCoercion) - do_one ty n = case lookup n param_eqs of - Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev)) - Nothing -> (ty, mkTcReflCo ty) -- Identity - - get_fst_ty (wev,_wloc) - | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev ) - = ty1 - | otherwise - = panic "rewriteDictParams: non equality fundep!?" - - -emitFDWork :: Bool - -> [(EvVar,WantedLoc)] - -> SubGoalDepth -> TcS () -emitFDWork as_wanted evlocs d - = updWorkListTcS $ appendWorkListEqs fd_cts - where fd_cts = map mk_fd_ct evlocs - mk_fl wl = if as_wanted then (Wanted wl) else (Derived wl) - mk_fd_ct (v,wl) = CNonCanonical { cc_id = v - , cc_flavor = mk_fl wl - , cc_depth = d } - -emitFDWorkAsDerived, emitFDWorkAsWanted :: [(EvVar,WantedLoc)] - -> SubGoalDepth - -> TcS () -emitFDWorkAsDerived = emitFDWork False -emitFDWorkAsWanted = emitFDWork True - -\end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 77f1c42982..ac1895fe35 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -363,7 +363,7 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name = -- A generic default method -- If the method is defined generically, we only have to call the -- dm_name. - do { dflags <- getDOpts + do { dflags <- getDynFlags ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 67b36bf733..7751ae49d2 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -331,23 +331,23 @@ tcDeriving tycl_decls inst_decls deriv_decls ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot (inst_infos ++ (bagToList extraInstances)) binds - ; dflags <- getDOpts + ; dflags <- getDynFlags ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" (ddump_deriving inst_info rn_binds newTyCons famInsts)) ; let all_tycons = map ATyCon (bagToList newTyCons) ; gbl_env <- tcExtendGlobalEnv all_tycons $ tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ - tcExtendLocalFamInstEnv (map mkLocalFamInst (bagToList famInsts)) $ + tcExtendLocalFamInstEnv (bagToList famInsts) $ tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv ; return (addTcgDUs gbl_env rn_dus, inst_info, rn_binds) } where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name - -> Bag TyCon -- ^ Empty data constructors - -> Bag TyCon -- ^ Rep type family instances + -> Bag TyCon -- ^ Empty data constructors + -> Bag FamInst -- ^ Rep type family instances -> SDoc - ddump_deriving inst_infos extra_binds repMetaTys repTyCons + ddump_deriving inst_infos extra_binds repMetaTys repFamInsts = hang (ptext (sLit "Derived instances:")) 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds) @@ -355,11 +355,14 @@ tcDeriving tycl_decls inst_decls deriv_decls hangP "Generated datatypes for meta-information:" (vcat (map ppr (bagToList repMetaTys))) $$ hangP "Representation types:" - (vcat (map pprTyFamInst (bagToList repTyCons)))) - - pprTyFamInst t = ppr t <+> text "=" <+> ppr (synTyConType t) + (vcat (map pprRepTy (bagToList repFamInsts)))) + hangP s x = text "" $$ hang (ptext (sLit s)) 2 x +-- Prints the representable type family instance +pprRepTy :: FamInst -> SDoc +pprRepTy fi + = pprFamInstHdr fi <+> ptext (sLit "=") <+> ppr (coAxiomRHS (famInstAxiom fi)) renameDeriv :: Bool -> [InstInfo RdrName] @@ -456,7 +459,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls all_tydata :: [(LHsType Name, LTyClDecl Name)] -- Derived predicate paired with its data type declaration - all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls) + all_tydata = extractTyDataPreds (instDeclFamInsts inst_decls ++ tycl_decls) deriv_locs = map (getLoc . snd) all_tydata ++ map getLoc deriv_decls @@ -614,7 +617,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta mk_alg_eqn tycon tc_args | className cls `elem` typeableClassNames - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; case checkTypeableConditions (dflags, tycon) of Just err -> bale_out err Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta } @@ -638,7 +641,7 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta ; unless (isNothing mtheta || not hidden_data_cons) (bale_out (derivingHiddenErr tycon)) - ; dflags <- getDOpts + ; dflags <- getDynFlags ; if isDataTyCon rep_tc then mkDataTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta @@ -1349,7 +1352,7 @@ inferInstanceContexts oflag infer_specs the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ -mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance +mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> ClsInst mkInstance overlap_flag theta (DS { ds_name = dfun_name , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys }) @@ -1358,7 +1361,7 @@ mkInstance overlap_flag theta dfun = mkDictFunId dfun_name tyvars theta clas tys -extendLocalInstEnv :: [Instance] -> TcM a -> TcM a +extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances; don't bother to check -- for functional dependency errors -- that'll happen in TcInstDcls extendLocalInstEnv dfuns thing_inside @@ -1513,25 +1516,25 @@ genDerivStuff loc fix_env clas name tycon %************************************************************************ \begin{code} -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc derivingKindErr tc cls cls_tys cls_kind = hang (ptext (sLit "Cannot derive well-kinded instance of form") <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "...")))) 2 (ptext (sLit "Class") <+> quotes (ppr cls) <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> Message +derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc derivingEtaErr cls cls_tys inst_ty = sep [ptext (sLit "Cannot eta-reduce to an instance of form"), nest 2 (ptext (sLit "instance (...) =>") <+> pprClassPred cls (cls_tys ++ [inst_ty]))] -typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message +typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> MsgDoc typeFamilyPapErr tc cls cls_tys inst_ty = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty]))) 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) -derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message +derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving clas tys ty why = sep [(hang (ptext (sLit "Can't make a derived instance of")) 2 (quotes (ppr pred)) @@ -1551,7 +1554,7 @@ standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: PredType -> Message +derivInstCtxt :: PredType -> MsgDoc derivInstCtxt pred = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 5c2c895866..ae320ce692 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -17,7 +17,7 @@ module TcEnv( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupInstance, + tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, -- Local environment tcExtendKindEnv, tcExtendKindEnvTvs, tcExtendTcTyThingEnv, @@ -45,7 +45,7 @@ module TcEnv( topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids - newLocalName, newDFunName, newFamInstTyConName, + newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName, mkStableIdFromString, mkStableIdFromName ) where @@ -164,6 +164,13 @@ tcLookupTyCon name = do ATyCon tc -> return tc _ -> wrongThingErr "type constructor" (AGlobal thing) name +tcLookupAxiom :: Name -> TcM CoAxiom +tcLookupAxiom name = do + thing <- tcLookupGlobal name + case thing of + ACoAxiom ax -> return ax + _ -> wrongThingErr "axiom" (AGlobal thing) name + tcLookupLocatedGlobalId :: Located Name -> TcM Id tcLookupLocatedGlobalId = addLocM tcLookupId @@ -176,7 +183,7 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely -- the same as in the instance declaration (modulo renaming). -- -tcLookupInstance :: Class -> [Type] -> TcM Instance +tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of @@ -551,7 +558,7 @@ tcGetDefaultTys :: Bool -- True <=> interactive context (Bool, -- True <=> Use overloaded strings Bool)) -- True <=> Use extended defaulting rules tcGetDefaultTys interactive - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; let ovl_strings = xopt Opt_OverloadedStrings dflags extended_defaults = interactive || xopt Opt_ExtendedDefaultRules dflags @@ -610,7 +617,7 @@ as well as explicit user written ones. \begin{code} data InstInfo a = InstInfo { - iSpec :: Instance, -- Includes the dfun id. Its forall'd type + iSpec :: ClsInst, -- Includes the dfun id. Its forall'd type iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } @@ -688,13 +695,17 @@ Make a name for the representation tycon of a family instance. It's an newGlobalBinder. \begin{code} -newFamInstTyConName :: Located Name -> [Type] -> TcM Name -newFamInstTyConName (L loc tc_name) tys +newFamInstTyConName, newFamInstAxiomName :: Located Name -> [Type] -> TcM Name +newFamInstTyConName = mk_fam_inst_name id +newFamInstAxiomName = mk_fam_inst_name mkInstTyCoOcc + +mk_fam_inst_name :: (OccName -> OccName) -> Located Name -> [Type] -> TcM Name +mk_fam_inst_name adaptOcc (L loc tc_name) tys = do { mod <- getModule ; let info_string = occNameString (getOccName tc_name) ++ concatMap (occNameString.getDFunTyKey) tys ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) - ; newGlobalBinder mod occ loc } + ; newGlobalBinder mod (adaptOcc occ) loc } \end{code} Stable names used for foreign exports and annotations. diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 893cd7a9ed..56a42e7eed 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,4 +1,5 @@ \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -7,9 +8,10 @@ -- for details module TcErrors( - reportUnsolved, + reportUnsolved, ErrEnv, warnDefaulting, unifyCtxt, + misMatchMsg, flattenForAllErrorTcS, solverDepthErrorTcS @@ -19,32 +21,31 @@ module TcErrors( import TcRnMonad import TcMType -import TcSMonad import TcType import TypeRep import Type -import Class -import Unify ( tcMatchTys ) +import Kind ( isKind ) +import Unify ( tcMatchTys ) import Inst import InstEnv import TyCon +import TcEvidence import Name import NameEnv -import Id ( idType ) +import Id ( idType ) import Var import VarSet import VarEnv -import SrcLoc import Bag -import BasicTypes ( IPName ) -import ListSetOps( equivClasses ) -import Maybes( mapCatMaybes ) +import Maybes +import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) import Util import FastString import Outputable import DynFlags -import Data.List( partition ) -import Control.Monad( when, unless, filterM ) +import Data.List ( partition, mapAccumL ) +import Data.Either ( partitionEithers ) +-- import Control.Monad ( when ) \end{code} %************************************************************************ @@ -58,26 +59,40 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -reportUnsolved :: WantedConstraints -> TcM () -reportUnsolved wanted +-- We keep an environment mapping coercion ids to the error messages they +-- trigger; this is handy for -fwarn--type-errors +type ErrEnv = VarEnv [ErrMsg] + +reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind) +reportUnsolved runtimeCoercionErrors wanted | isEmptyWC wanted - = return () + = return emptyBag | otherwise = do { -- Zonk to un-flatten any flatten-skols - ; wanted <- zonkWC wanted + wanted <- zonkWC wanted ; env0 <- tcInitTidyEnv + ; defer <- if runtimeCoercionErrors + then do { ev <- newTcEvBinds + ; return (Just ev) } + else return Nothing + + ; errs_so_far <- ifErrsM (return True) (return False) ; let tidy_env = tidyFreeTyVars env0 free_tvs free_tvs = tyVarsOfWC wanted err_ctxt = CEC { cec_encl = [] - , cec_insol = insolubleWC wanted + , cec_insol = errs_so_far , cec_extra = empty - , cec_tidy = tidy_env } - tidy_wanted = tidyWC tidy_env wanted + , cec_tidy = tidy_env + , cec_defer = defer } + + ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted) - ; traceTc "reportUnsolved" (ppr tidy_wanted) + ; reportWanteds err_ctxt wanted - ; reportTidyWanteds err_ctxt tidy_wanted } + ; case defer of + Nothing -> return emptyBag + Just ev -> getTcEvBinds ev } -------------------------------------------- -- Internal functions @@ -86,175 +101,265 @@ reportUnsolved wanted data ReportErrCtxt = CEC { cec_encl :: [Implication] -- Enclosing implications -- (innermost first) + -- ic_skols and givens are tidied, rest are not , cec_tidy :: TidyEnv , cec_extra :: SDoc -- Add this to each error message - , cec_insol :: Bool -- True <=> we are reporting insoluble errors only - -- Main effect: don't say "Cannot deduce..." - -- when reporting equality errors; see misMatchOrCND + , cec_insol :: Bool -- True <=> do not report errors involving + -- ambiguous errors + , cec_defer :: Maybe EvBindsVar + -- Nothinng <=> errors are, well, errors + -- Just ev <=> make errors into warnings, and emit evidence + -- bindings into 'ev' for unsolved constraints } -reportTidyImplic :: ReportErrCtxt -> Implication -> TcM () -reportTidyImplic ctxt implic - | BracketSkol <- ctLocOrigin (ic_loc implic) - , not insoluble -- For Template Haskell brackets report only - = return () -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_insol = insoluble, ic_loc = loc }) + | BracketSkol <- ctLocOrigin loc + , not insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints | otherwise - = reportTidyWanteds ctxt' (ic_wanted implic) + = reportWanteds ctxt' wanted where - insoluble = ic_insol implic - ctxt' = ctxt { cec_encl = implic : cec_encl ctxt - , cec_insol = insoluble } - -reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () -reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) - | cec_insol ctxt -- If there are any insolubles, report only them - -- because they are unconditionally wrong - -- Moreover, if any of the insolubles are givens, stop right there - -- ignoring nested errors, because the code is inaccessible - = do { let (given, other) = partitionBag (isGivenOrSolved . cc_flavor) insols - insol_implics = filterBag ic_insol implics - ; if isEmptyBag given - then do { mapBagM_ (reportInsoluble ctxt) other - ; mapBagM_ (reportTidyImplic ctxt) insol_implics } - else mapBagM_ (reportInsoluble ctxt) given } - - | otherwise -- No insoluble ones - = ASSERT( isEmptyBag insols ) - do { let flat_evs = bagToList $ mapBag to_wev flats - to_wev ct | Wanted wl <- cc_flavor ct = mkEvVarX (cc_id ct) wl - | otherwise = panic "reportTidyWanteds: unsolved is not wanted!" - (ambigs, non_ambigs) = partition is_ambiguous flat_evs - (tv_eqs, others) = partitionWith is_tv_eq non_ambigs - - ; groupErrs (reportEqErrs ctxt) tv_eqs - ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others - ; mapBagM_ (reportTidyImplic ctxt) implics - - -- Only report ambiguity if no other errors (at all) happened - -- See Note [Avoiding spurious errors] in TcSimplify - ; ifErrsM (return ()) $ reportAmbigErrs ctxt ambigs } + (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_loc = tidyGivenLoc env1 loc } + ctxt' = ctxt { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + , cec_defer = case cec_defer ctxt of + Nothing -> Nothing + Just {} -> Just evb } + +reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () +reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) + = reportTidyWanteds ctxt tidy_insols tidy_flats implics where - -- Report equalities of form (a~ty) first. They are usually - -- skolem-equalities, and they cause confusing knock-on - -- effects in other errors; see test T4093b. - is_tv_eq c | Just (ty1, ty2) <- getEqPredTys_maybe (evVarOfPred c) - , tcIsTyVarTy ty1 || tcIsTyVarTy ty2 - = Left (c, (ty1, ty2)) - | otherwise - = Right (c, evVarOfPred c) - - -- Treat it as "ambiguous" if - -- (a) it is a class constraint - -- (b) it constrains only type variables - -- (else we'd prefer to report it as "no instance for...") - -- (c) it mentions a (presumably un-filled-in) meta type variable - is_ambiguous d = isTyVarClassPred pred - && any isAmbiguousTyVar (varSetElems (tyVarsOfType pred)) - where - pred = evVarOfPred d - -reportInsoluble :: ReportErrCtxt -> Ct -> TcM () --- Precondition: insolubles are always NonCanonicals! -reportInsoluble ctxt ct - | ev <- cc_id ct - , flav <- cc_flavor ct - , Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev) - = setCtFlavorLoc flav $ - do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg } - ; reportEqErr ctxt2 ty1 ty2 } + env = cec_tidy ctxt + tidy_insols = mapBag (tidyCt env) insols + tidy_flats = mapBag (tidyCt env) flats + +reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM () +reportTidyWanteds ctxt insols flats implics + | Just ev_binds_var <- cec_defer ctxt + = do { -- Defer errors to runtime + -- See Note [Deferring coercion errors to runtime] in TcSimplify + mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) + (flats `unionBags` insols) + ; mapBagM_ (reportImplic ctxt) implics } + | otherwise - = pprPanic "reportInsoluble" (pprEvVarWithType (cc_id ct)) + = do { reportInsolsAndFlats ctxt insols flats + ; mapBagM_ (reportImplic ctxt) implics } + + +deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) + -> Ct -> TcM () +deferToRuntime ev_binds_var ctxt mk_err_msg ct + | Wanted loc <- cc_flavor ct + = do { err <- setCtLoc loc $ + mk_err_msg ctxt ct + ; let ev_id = cc_id ct + err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc $ + err_msg $$ text "(deferred type error)" + + -- Create the binding + ; addTcEvBind ev_binds_var ev_id (EvDelayedError (idType ev_id) err_fs) + + -- And emit a warning + ; reportWarning (makeIntoWarning err) } + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM () +reportInsolsAndFlats ctxt insols flats + = tryReporters + [ -- First deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + ("Utterly wrong", utterly_wrong, groupErrs (mkEqErr ctxt)) + + -- Report equalities of form (a~ty). They are usually + -- skolem-equalities, and they cause confusing knock-on + -- effects in other errors; see test T4093b. + , ("Skolem equalities", skolem_eq, mkReporter (mkEqErr1 ctxt)) + + , ("Unambiguous", unambiguous, reportFlatErrs ctxt) ] + (reportAmbigErrs ctxt) + (bagToList (insols `unionBags` flats)) + where + utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool + + utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 + utterly_wrong _ _ = False + + skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 + skolem_eq _ _ = False + + unambiguous ct pred + | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct))) + = True + | otherwise + = case pred of + EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2) + _ -> False + +--------------- +isRigid, isRigidOrSkol :: Type -> Bool +isRigid ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | otherwise = False + +isRigidOrSkol ty + | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv + | otherwise = isRigid ty + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isSynFamilyTyCon tc -> Just tc + _ -> Nothing + +----------------- +type Reporter = [Ct] -> TcM () + +mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM () +-- Reports errors one at a time +mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_flavor ct) $ + mk_err ct; + ; reportError err }) + +tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter +tryReporters reporters deflt cts + = do { traceTc "tryReporters {" (ppr cts) + ; go reporters cts + ; traceTc "tryReporters }" empty } where - inaccessible_msg | Given loc GivenOrig <- (cc_flavor ct) - -- If a GivenSolved then we should not report inaccessible code - = hang (ptext (sLit "Inaccessible code in")) - 2 (ppr (ctLocOrigin loc)) - | otherwise = empty - -reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () --- The [PredType] are already tidied -reportFlat ctxt flats origin - = do { unless (null dicts) $ reportDictErrs ctxt dicts origin - ; unless (null eqs) $ reportEqErrs ctxt eqs origin - ; unless (null ips) $ reportIPErrs ctxt ips origin - ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin } + go [] cts = deflt cts + go ((str, pred, reporter) : rs) cts + | null yeses = traceTc "tryReporters: no" (text str) >> + go rs cts + | otherwise = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> + reporter yeses + where + yeses = filter keep_me cts + keep_me ct = pred ct (classifyPredType (ctPred ct)) + +----------------- +mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Context is already set +mkFlatErr ctxt ct -- The constraint is always wanted + = case classifyPredType (ctPred ct) of + ClassPred {} -> mkDictErr ctxt [ct] + IPPred {} -> mkIPErr ctxt [ct] + IrredPred {} -> mkIrredErr ctxt [ct] + EqPred {} -> mkEqErr1 ctxt ct + TuplePred {} -> panic "mkFlat" + +reportAmbigErrs :: ReportErrCtxt -> Reporter +reportAmbigErrs ctxt cts + | cec_insol ctxt = return () + | otherwise = reportFlatErrs ctxt cts + -- Only report ambiguity if no other errors (at all) happened + -- See Note [Avoiding spurious errors] in TcSimplify + +reportFlatErrs :: ReportErrCtxt -> Reporter +-- Called once for non-ambigs, once for ambigs +-- Report equality errors, and others only if we've done all +-- the equalities. The equality errors are more basic, and +-- can lead to knock on type-class errors +reportFlatErrs ctxt cts + = tryReporters + [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ] + (\cts -> do { let (dicts, ips, irreds) = go cts [] [] [] + ; groupErrs (mkIPErr ctxt) ips + ; groupErrs (mkIrredErr ctxt) irreds + ; groupErrs (mkDictErr ctxt) dicts }) + cts where - (dicts, eqs, ips, irreds) = go_many (map classifyPredType flats) - - go_many [] = ([], [], [], []) - go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds') - where (as, bs, cs, ds) = go t - (as', bs', cs', ds') = go_many ts - - go (ClassPred cls tys) = ([(cls, tys)], [], [], []) - go (EqPred ty1 ty2) = ([], [(ty1, ty2)], [], []) - go (IPPred ip ty) = ([], [], [(ip, ty)], []) - go (IrredPred ty) = ([], [], [], [ty]) - go (TuplePred {}) = panic "reportFlat" + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + go [] dicts ips irreds + = (dicts, ips, irreds) + go (ct:cts) dicts ips irreds + = case classifyPredType (ctPred ct) of + ClassPred {} -> go cts (ct:dicts) ips irreds + IPPred {} -> go cts dicts (ct:ips) irreds + IrredPred {} -> go cts dicts ips (ct:irreds) + _ -> panic "mkFlat" -- TuplePreds should have been expanded away by the constraint -- simplifier, so they shouldn't show up at this point + -- And EqPreds are dealt with by the is_equality test + -------------------------------------------- -- Support code -------------------------------------------- -groupErrs :: ([a] -> CtOrigin -> TcM ()) -- Deal with one group - -> [(WantedEvVar, a)] -- Unsolved wanteds +groupErrs :: ([Ct] -> TcM ErrMsg) -- Deal with one group + -> [Ct] -- Unsolved wanteds -> TcM () --- Group together insts with the same origin +-- Group together insts from same location -- We want to report them together in error messages groupErrs _ [] = return () -groupErrs report_err ((wanted, x) : wanteds) - = do { setCtLoc the_loc $ - report_err the_xs (ctLocOrigin the_loc) - ; groupErrs report_err others } +groupErrs mk_err (ct1 : rest) + = do { err <- setCtFlavorLoc flavor $ mk_err cts + ; reportError err + ; groupErrs mk_err others } where - the_loc = evVarX wanted - the_key = mk_key the_loc - the_xs = x:map snd friends - (friends, others) = partition (is_friend . fst) wanteds - is_friend friend = mk_key (evVarX friend) `same_key` the_key + flavor = cc_flavor ct1 + cts = ct1 : friends + (friends, others) = partition is_friend rest + is_friend friend = cc_flavor friend `same_group` flavor - mk_key :: WantedLoc -> (SrcSpan, CtOrigin) - mk_key loc = (ctLocSpan loc, ctLocOrigin loc) - - same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2 - same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2 - same_orig ScOrigin ScOrigin = True - same_orig DerivOrigin DerivOrigin = True - same_orig DefaultOrigin DefaultOrigin = True - same_orig _ _ = False + same_group :: CtFlavor -> CtFlavor -> Bool + same_group (Given l1 _) (Given l2 _) = same_loc l1 l2 + same_group (Derived l1) (Derived l2) = same_loc l1 l2 + same_group (Wanted l1) (Wanted l2) = same_loc l1 l2 + same_group _ _ = False + same_loc :: CtLoc o -> CtLoc o -> Bool + same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2 -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc addArising orig msg = msg $$ nest 2 (pprArising orig) -pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) +pprWithArising :: [Ct] -> (WantedLoc, SDoc) -- Print something like -- (Eq a) arising from a use of x at y -- (Show a) arising from a use of p at q -- Also return a location for the error message +-- Works for Wanted/Derived only pprWithArising [] = panic "pprWithArising" -pprWithArising [EvVarX ev loc] - = (loc, hang (pprEvVarTheta [ev]) 2 (pprArising (ctLocOrigin loc))) -pprWithArising ev_vars - = (first_loc, vcat (map ppr_one ev_vars)) +pprWithArising (ct:cts) + | null cts + = (loc, hang (pprEvVarTheta [cc_id ct]) + 2 (pprArising (ctLocOrigin (ctWantedLoc ct)))) + | otherwise + = (loc, vcat (map ppr_one (ct:cts))) where - first_loc = evVarX (head ev_vars) - ppr_one (EvVarX v loc) - = hang (parens (pprType (evVarPred v))) 2 (pprArisingAt loc) + loc = ctWantedLoc ct + ppr_one ct = hang (parens (pprType (ctPred ct))) + 2 (pprArisingAt (ctWantedLoc ct)) -addErrorReport :: ReportErrCtxt -> SDoc -> TcM () -addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) +mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg +mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) -getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)] +type UserGiven = ([EvVar], GivenLoc) + +getUserGivens :: ReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ @@ -269,12 +374,14 @@ getUserGivens (CEC {cec_encl = ctxt}) %************************************************************************ \begin{code} -reportIrredsErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () -reportIrredsErrs ctxt irreds orig - = addErrorReport ctxt msg +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr ctxt cts + = mkErrorReport ctxt msg where - givens = getUserGivens ctxt - msg = couldNotDeduce givens (irreds, orig) + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) + givens = getUserGivens ctxt + msg = couldNotDeduce givens (map ctPred cts, orig) \end{code} @@ -285,17 +392,21 @@ reportIrredsErrs ctxt irreds orig %************************************************************************ \begin{code} -reportIPErrs :: ReportErrCtxt -> [(IPName Name, Type)] -> CtOrigin -> TcM () -reportIPErrs ctxt ips orig - = addErrorReport ctxt msg +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr ctxt cts + = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts + ; mkErrorReport ctxt' (msg $$ ambig_err) } where - givens = getUserGivens ctxt + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) + preds = map ctPred cts + givens = getUserGivens ctxt msg | null givens = addArising orig $ - sep [ ptext (sLit "Unbound implicit parameter") <> plural ips - , nest 2 (pprTheta (map (uncurry mkIPPred) ips)) ] + sep [ ptext (sLit "Unbound implicit parameter") <> plural cts + , nest 2 (pprTheta preds) ] | otherwise - = couldNotDeduce givens (map (uncurry mkIPPred) ips, orig) + = couldNotDeduce givens (preds, orig) \end{code} @@ -306,69 +417,88 @@ reportIPErrs ctxt ips orig %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [(Type, Type)] -> CtOrigin -> TcM () --- The [PredType] are already tidied -reportEqErrs ctxt eqs orig - = do { orig' <- zonkTidyOrigin ctxt orig - ; mapM_ (report_one orig') eqs } +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Wanted constraints only! +mkEqErr1 ctxt ct + = case cc_flavor ct of + Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2 + where + ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ + inaccessible_msg gl gk } + + flav -> do { let orig = ctLocOrigin (getWantedLoc flav) + ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig + ; mk_err ctxt1 orig' } where - report_one orig (ty1, ty2) - = do { let extra = getWantedEqExtra orig ty1 ty2 - ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt } - ; reportEqErr ctxt' ty1 ty2 } - -getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc -getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - ty1 ty2 - -- If the types in the error message are the same as the types we are unifying, - -- don't add the extra expected/actual message - | act `eqType` ty1 && exp `eqType` ty2 = empty - | exp `eqType` ty1 && act `eqType` ty2 = empty - | otherwise = mkExpectedActualMsg act exp - -getWantedEqExtra orig _ _ = pprArising orig - -reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM () --- ty1 and ty2 are already tidied -reportEqErr ctxt ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1 - - | otherwise -- Neither side is a type variable - -- Since the unsolved constraint is canonical, - -- it must therefore be of form (F tys ~ ty) - = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2) - - -reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () + -- If a GivenSolved then we should not report inaccessible code + inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ctLocOrigin loc)) + inaccessible_msg _ _ = empty + + (ty1, ty2) = getEqPredTys (evVarPred (cc_id ct)) + + -- If the types in the error message are the same as the types + -- we are unifying, don't add the extra expected/actual message + mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) + | act `pickyEqType` ty1 + , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty2 ty1 + | exp `pickyEqType` ty1 + , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty1 ty2 + | otherwise = mkEqErr_help ctxt2 ct False ty1 ty2 + where + ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 } + msg = mkExpectedActualMsg exp act + mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2 + +mkEqErr_help :: ReportErrCtxt + -> Ct + -> Bool -- True <=> Types are correct way round; + -- report "expected ty1, actual ty2" + -- False <=> Just report a mismatch without orientation + -- The ReportErrCtxt has expected/actual + -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help ctxt ct oriented ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1 + | otherwise -- Neither side is a type variable + = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 + ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } + +mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied -reportTyVarEqErr ctxt tv1 ty2 +mkTyVarEqErr ctxt ct oriented tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would -- be oriented the other way round; see TcCanonical.reOrient || isSigTyVar tv1 && not (isTyVarTy ty2) - = addErrorReport (addExtraInfo ctxt ty1 ty2) - (misMatchOrCND ctxt ty1 ty2) + = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) + (misMatchOrCND ctxt ct oriented ty1 ty2) -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified | not (k2 `isSubKind` k1) -- Kind error - = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) + = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) -- Occurs check | tv1 `elemVarSet` tyVarsOfType ty2 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '=', ppr ty2]) - in addErrorReport ctxt occCheckMsg + in mkErrorReport ctxt occCheckMsg -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic) + , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic) implic_loc = ic_loc implic , not (null esc_skols) = setCtLoc implic_loc $ -- Override the error message location from the -- place the equality arose to the implication site - do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1) - ; let msg = misMatchMsg ty1 ty2 + do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1) + ; let msg = misMatchMsg oriented ty1 ty2 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols <+> pprQuotedList esc_skols , ptext (sLit "would escape") <+> @@ -380,23 +510,23 @@ reportTyVarEqErr ctxt tv1 ty2 else ptext (sLit "These (rigid, skolem) type variables are")) <+> ptext (sLit "bound by") , nest 2 $ ppr (ctLocOrigin implic_loc) ] ] - ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } + ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } -- Nastiest case: attempt to unify an untouchable variable | (implic:_) <- cec_encl ctxt -- Get the innermost context , let implic_loc = ic_loc implic given = ic_given implic = setCtLoc (ic_loc implic) $ - do { let msg = misMatchMsg ty1 ty2 + do { let msg = misMatchMsg oriented ty1 ty2 extra = quotes (ppr tv1) <+> sep [ ptext (sLit "is untouchable") , ptext (sLit "inside the constraints") <+> pprEvVarTheta given , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] - ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } + ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } | otherwise - = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ - return () + = pprTrace "mkTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ + panic "mkTyVarEqErr" -- I don't think this should happen, and if it does I want to know -- Trac #5130 happened because an actual type error was not -- reported at all! So not reporting is pretty dangerous. @@ -415,30 +545,43 @@ reportTyVarEqErr ctxt tv1 ty2 k2 = typeKind ty2 ty1 = mkTyVarTy tv1 -mkTyFunInfoMsg :: TcType -> TcType -> SDoc --- See Note [Non-injective type functions] -mkTyFunInfoMsg ty1 ty2 - | Just (tc1,_) <- tcSplitTyConApp_maybe ty1 - , Just (tc2,_) <- tcSplitTyConApp_maybe ty2 - , tc1 == tc2, isSynFamilyTyCon tc1 - = ptext (sLit "NB:") <+> quotes (ppr tc1) - <+> ptext (sLit "is a type function") <> (pp_inj tc1) - | otherwise = empty - where - pp_inj tc | isInjectiveTyCon tc = empty - | otherwise = ptext (sLit (", and may not be injective")) - -misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc -misMatchOrCND ctxt ty1 ty2 - | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally - -- insoluble, don't report the context - | null givens = misMatchMsg ty1 ty2 - | otherwise = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) +mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +mkEqInfoMsg ctxt ct ty1 ty2 + = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2 + then mkAmbigMsg ctxt [ct] + else return (ctxt, False, empty) + ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) } + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + = ptext (sLit "NB:") <+> quotes (ppr tc1) + <+> ptext (sLit "is a type function, and may not be injective") + | otherwise = empty + +misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc +-- If oriented then ty1 is expected, ty2 is actual +misMatchOrCND ctxt ct oriented ty1 ty2 + | null givens || + (isRigid ty1 && isRigid ty2) || + isGivenOrSolved (cc_flavor ct) + -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + = misMatchMsg oriented ty1 ty2 + | otherwise + = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) -couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc +couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) 2 (pprArising orig) @@ -455,31 +598,18 @@ pp_givens givens 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) -addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt +addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt -- Add on extra info about the types themselves -- NB: The types themselves are already tidied -addExtraInfo ctxt ty1 ty2 +addExtraTyVarInfo ctxt ty1 ty2 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } where - extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1 - extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2 - -misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy -misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1) - , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)] - -kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy -kindErrorMsg ty1 ty2 - = vcat [ ptext (sLit "Kind incompatibility when matching types:") - , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 - , ppr ty2 <+> dcolon <+> ppr k2 ]) ] - where - k1 = typeKind ty1 - k2 = typeKind ty2 + extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1 + extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2 -typeExtraInfoMsg :: [Implication] -> Type -> SDoc +tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants -typeExtraInfoMsg implics ty +tyVarExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty , isTcTyVar tv, isSkolemTyVar tv , let pp_tv = quotes (ppr tv) @@ -497,15 +627,37 @@ typeExtraInfoMsg implics ty ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), sep [ppr info, ptext (sLit "at") <+> ppr loc]] +kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy +kindErrorMsg ty1 ty2 + = vcat [ ptext (sLit "Kind incompatibility when matching types:") + , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 + , ppr ty2 <+> dcolon <+> ppr k2 ]) ] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + -------------------- unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty - ; return (env2, mkExpectedActualMsg act_ty' exp_ty') } + ; return (env2, mkExpectedActualMsg exp_ty' act_ty') } + +misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy +-- If oriented then ty1 is expected, ty2 is actual +misMatchMsg oriented ty1 ty2 + | oriented + = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1) + , nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ] + | otherwise + = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1) + , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2) ] + where + what | isKind ty1 = ptext (sLit "kind") + | otherwise = ptext (sLit "type") mkExpectedActualMsg :: Type -> Type -> SDoc -mkExpectedActualMsg act_ty exp_ty +mkExpectedActualMsg exp_ty act_ty = vcat [ text "Expected type" <> colon <+> ppr exp_ty , text " Actual type" <> colon <+> ppr act_ty ] \end{code} @@ -528,27 +680,33 @@ Warn of loopy local equalities that were dropped. %************************************************************************ \begin{code} -reportDictErrs :: ReportErrCtxt -> [(Class, [Type])] -> CtOrigin -> TcM () -reportDictErrs ctxt wanteds orig +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr ctxt cts = do { inst_envs <- tcGetInstEnvs - ; non_overlaps <- filterM (reportOverlap ctxt inst_envs orig) wanteds - ; unless (null non_overlaps) $ - addErrorReport ctxt (mk_no_inst_err non_overlaps) } + ; stuff <- mapM (mkOverlap ctxt inst_envs orig) cts + ; let (non_overlaps, overlap_errs) = partitionEithers stuff + ; if null non_overlaps + then mkErrorReport ctxt (vcat overlap_errs) + else do + { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt cts + ; mkErrorReport ctxt' + (vcat [ mkNoInstErr givens non_overlaps orig + , ambig_msg + , mk_no_inst_fixes is_ambig non_overlaps]) } } where - mk_no_inst_err :: [(Class, [Type])] -> SDoc - mk_no_inst_err wanteds - | null givens -- Top level - = vcat [ addArising orig $ - ptext (sLit "No instance") <> plural min_wanteds - <+> ptext (sLit "for") <+> pprTheta min_wanteds - , show_fixes (fixes2 ++ fixes3) ] + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) - | otherwise - = vcat [ couldNotDeduce givens (min_wanteds, orig) - , show_fixes (fixes1 ++ fixes2 ++ fixes3) ] + givens = getUserGivens ctxt + + mk_no_inst_fixes is_ambig cts + | null givens = show_fixes (fixes2 ++ fixes3) + | otherwise = show_fixes (fixes1 ++ fixes2 ++ fixes3) where - givens = getUserGivens ctxt - min_wanteds = mkMinimalBySCs (map (uncurry mkClassPred) wanteds) + min_wanteds = map ctPred cts + instance_dicts = filterOut isTyVarClassPred min_wanteds + -- Insts for which it is worth suggesting an adding an + -- instance declaration. Exclude tyvar dicts. fixes2 = case instance_dicts of [] -> [] @@ -560,19 +718,11 @@ reportDictErrs ctxt wanteds orig DerivOrigin -> [drv_fix] _ -> [] - instance_dicts = filterOut isTyVarClassPred min_wanteds - -- Insts for which it is worth suggesting an adding an - -- instance declaration. Exclude tyvar dicts. - drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"), nest 2 $ ptext (sLit "so you can specify the instance context yourself")] - show_fixes :: [SDoc] -> SDoc - show_fixes [] = empty - show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), - nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] - - fixes1 | (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) + fixes1 | not is_ambig + , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) = [sep [ ptext (sLit "add") <+> pprTheta min_wanteds <+> ptext (sLit "to the context of") , nest 2 $ ppr_skol orig $$ @@ -589,19 +739,38 @@ reportDictErrs ctxt wanteds orig SigSkol (InfSigCtxt {}) _ -> Nothing origin -> Just origin -reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin - -> (Class, [Type]) -> TcM Bool + + show_fixes :: [SDoc] -> SDoc + show_fixes [] = empty + show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") + , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] + +mkNoInstErr :: [UserGiven] -> [Ct] -> CtOrigin -> SDoc +mkNoInstErr givens cts orig + | null givens -- Top level + = addArising orig $ + ptext (sLit "No instance") <> plural cts + <+> ptext (sLit "for") <+> pprTheta theta + + | otherwise + = couldNotDeduce givens (theta, orig) + where + theta = map ctPred cts + +mkOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin + -> Ct -> TcM (Either Ct SDoc) -- Report an overlap error if this class constraint results --- from an overlap (returning Nothing), otherwise return (Just pred) -reportOverlap ctxt inst_envs orig (clas, tys) +-- from an overlap (returning Left clas), otherwise return (Right pred) +mkOverlap ctxt inst_envs orig ct = do { tys_flat <- mapM quickFlattenTy tys -- Note [Flattening in error message generation] ; case lookupInstEnv inst_envs clas tys_flat of - ([], _, _) -> return True -- No match - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return False } } + ([], _, _) -> return (Left ct) -- No match + res -> return (Right (mk_overlap_msg res)) } where + (clas, tys) = getClassPredTys (ctPred ct) + -- Normal overlap error mk_overlap_msg (matches, unifiers, False) = ASSERT( not (null matches) ) @@ -724,66 +893,60 @@ that match such things. And flattening under a for-all is problematic anyway; consider C (forall a. F a) \begin{code} -reportAmbigErrs :: ReportErrCtxt -> [WantedEvVar] -> TcM () -reportAmbigErrs ctxt ambigs --- Divide into groups that share a common set of ambiguous tyvars - = mapM_ (reportAmbigGroup ctxt) (equivClasses cmp ambigs_w_tvs) - where - ambigs_w_tvs = [ (d, filter isAmbiguousTyVar (varSetElems (tyVarsOfEvVarX d))) - | d <- ambigs ] - cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 - - -reportAmbigGroup :: ReportErrCtxt -> [(WantedEvVar, [TcTyVar])] -> TcM () --- The pairs all have the same [TcTyVar] -reportAmbigGroup ctxt pairs - = setCtLoc loc $ - do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet tvs) - ; addErrTcM (tidy_env, main_msg $$ mk_msg dflags docs) } +mkAmbigMsg :: ReportErrCtxt -> [Ct] + -> TcM (ReportErrCtxt, Bool, SDoc) +mkAmbigMsg ctxt cts + | isEmptyVarSet ambig_tv_set + = return (ctxt, False, empty) + | otherwise + = do { dflags <- getDynFlags + ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set + ; return (ctxt', True, mk_msg dflags gbl_docs) } where - (wev, tvs) : _ = pairs - (loc, pp_wanteds) = pprWithArising (map fst pairs) - main_msg = sep [ text "Ambiguous type variable" <> plural tvs - <+> pprQuotedList tvs - <+> text "in the constraint" <> plural pairs <> colon - , nest 2 pp_wanteds ] - + ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) + emptyVarSet cts + ambig_tvs = varSetElems ambig_tv_set + + is_or_are | isSingleton ambig_tvs = text "is" + | otherwise = text "are" + mk_msg dflags docs - | any isRuntimeUnkSkol tvs -- See Note [Runtime skolems] - = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> - (pprWithCommas ppr tvs), - ptext (sLit "Use :print or :force to determine these types")] - - | DerivOrigin <- ctLocOrigin (evVarX wev) - = ptext (sLit "Probable fix: use a 'standalone deriving' declaration instead") - - | null docs - = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") + | any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems] + = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + , ptext (sLit "Use :print or :force to determine these types")] + | otherwise + = vcat [ text "The type variable" <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + <+> is_or_are <+> text "ambiguous" + , mk_extra_msg dflags docs ] + + mk_extra_msg dflags docs + | null docs + = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") -- where monomorphism doesn't play any role - | otherwise - = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"), - nest 2 (vcat docs), - mono_fix dflags] - - mono_fix :: DynFlags -> SDoc - mono_fix dflags - = ptext (sLit "Probable fix:") <+> vcat - [ptext (sLit "give these definition(s) an explicit type signature"), - if xopt Opt_MonomorphismRestriction dflags - then ptext (sLit "or use -XNoMonomorphismRestriction") - else empty] -- Only suggest adding "-XNoMonomorphismRestriction" - -- if it is not already set! + | otherwise + = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:") + , nest 2 (vcat docs) + , ptext (sLit "Probable fix:") <+> vcat + [ ptext (sLit "give these definition(s) an explicit type signature") + , if xopt Opt_MonomorphismRestriction dflags + then ptext (sLit "or use -XNoMonomorphismRestriction") + else empty ] -- Only suggest adding "-XNoMonomorphismRestriction" + -- if it is not already set! + ] getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +-- Get the skolem info for a type variable +-- from the implication constraint that binds it getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) UnkSkol getSkolemInfo (implic:implics) tv - | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic) - | otherwise = getSkolemInfo implics tv + | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic) + | otherwise = getSkolemInfo implics tv ----------------------- -- findGlobals looks at the value environment and finds values whose @@ -799,7 +962,7 @@ mkEnvSigMsg what env_sigs findGlobals :: ReportErrCtxt -> TcTyVarSet - -> TcM (TidyEnv, [SDoc]) + -> TcM (ReportErrCtxt, [SDoc]) findGlobals ctxt tvs = do { lcl_ty_env <- case cec_encl ctxt of @@ -807,12 +970,12 @@ findGlobals ctxt tvs (i:_) -> return (ic_env i) ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) } where - go tidy_env acc [] = return (tidy_env, acc) - go tidy_env acc (thing : things) = do - (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing - case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things + go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc) + go tidy_env acc (thing : things) + = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing + ; case maybe_doc of + Just d -> go tidy_env1 (d:acc) things + Nothing -> go tidy_env1 acc things } ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty @@ -856,18 +1019,11 @@ warnDefaulting wanteds default_ty tidy_env = tidyFreeTyVars env0 $ tyVarsOfCts wanted_bag tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag - (loc, ppr_wanteds) = pprWithArising (map mk_wev (bagToList tidy_wanteds)) + (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) 2 ppr_wanteds ; setCtLoc loc $ warnTc warn_default warn_msg } - where mk_wev :: Ct -> WantedEvVar - mk_wev ct - | ev <- cc_id ct - , Wanted wloc <- cc_flavor ct - = EvVarX ev wloc -- must return a WantedEvVar - mk_wev _ct = panic "warnDefaulting: encountered non-wanted for defaulting" - \end{code} Note [Runtime skolems] @@ -884,13 +1040,12 @@ are created by in RtClosureInspect.zonkRTTIType. %************************************************************************ \begin{code} -solverDepthErrorTcS :: Int -> [Ct] -> TcS a +solverDepthErrorTcS :: Int -> [Ct] -> TcM a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 - = wrapErrTcS $ failWith msg + = failWith msg | otherwise - = wrapErrTcS $ - setCtFlavorLoc (cc_flavor top_item) $ + = setCtFlavorLoc (cc_flavor top_item) $ do { ev_vars <- mapM (zonkEvVar . cc_id) stack ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) @@ -901,10 +1056,9 @@ solverDepthErrorTcS depth stack msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] -flattenForAllErrorTcS :: CtFlavor -> TcType -> TcS a +flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a flattenForAllErrorTcS fl ty - = wrapErrTcS $ - setCtFlavorLoc fl $ + = setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv ; let (env1, ty') = tidyOpenType env0 ty msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:") @@ -936,12 +1090,11 @@ zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } -zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin +zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin) zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act - ; (_env2, exp') <- zonkTidyTcType env1 exp - ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } - -- Drop the returned env on the floor; we may conceivably thereby get - -- inconsistent naming between uses of this function -zonkTidyOrigin _ orig = return orig + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( ctxt { cec_tidy = env2 } + , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } +zonkTidyOrigin ctxt orig = return (ctxt, orig) \end{code} diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 0511aa1051..e18bb0c6a2 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -1,570 +1,600 @@ -%
-% (c) The University of Glasgow 2006
-%
-
-\begin{code}
-module TcEvidence (
-
- -- HsWrapper
- HsWrapper(..),
- (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet,
- idHsWrapper, isIdHsWrapper, pprHsWrapper,
-
- -- Evidence bindin
- TcEvBinds(..), EvBindsVar(..),
- EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds,
-
- EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
-
- EvTerm(..), mkEvCast, evVarsOfTerm,
-
- -- TcCoercion
- TcCoercion(..),
- mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo,
- mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos,
- mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcInstCos,
- tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo,
- isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe,
- liftTcCoSubstWith
-
- ) where
-#include "HsVersions.h"
-
-import Var
-
-import PprCore () -- Instance OutputableBndr TyVar
-import TypeRep -- Knows type representation
-import TcType
-import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe )
-import TysPrim( funTyCon )
-import TyCon
-import PrelNames
-import VarEnv
-import VarSet
-import Name
-
-import Util
-import Bag
-import Pair
-import Control.Applicative
-import Data.Traversable (traverse, sequenceA)
-import qualified Data.Data as Data
-import Outputable
-import FastString
-import Data.IORef( IORef )
-\end{code}
-
-
-Note [TcCoercions]
-~~~~~~~~~~~~~~~~~~
-| LCoercions are a hack used by the typechecker. Normally,
-Coercions have free variables of type (a ~# b): we call these
-CoVars. However, the type checker passes around equality evidence
-(boxed up) at type (a ~ b).
-
-An LCoercion is simply a Coercion whose free variables have the
-boxed type (a ~ b). After we are done with typechecking the
-desugarer finds the free variables, unboxes them, and creates a
-resulting real Coercion with kosher free variables.
-
-We can use most of the Coercion "smart constructors" to build LCoercions. However,
-mkCoVarCo will not work! The equivalent is mkTcCoVarCo.
-
-The data type is similar to Coercion.Coercion, with the following
-differences
- * Most important, TcLetCo adds let-bindings for coercions.
- This is what lets us unify two for-all types and generate
- equality constraints underneath
-
- * The kind of a TcCoercion is t1 ~ t2
- of a Coercion is t1 ~# t2
-
- * TcAxiomInstCo takes Types, not Coecions as arguments;
- the generality is required only in the Simplifier
-
- * UnsafeCo aren't required
-
- * Reprsentation invariants are weaker:
- - we are allowed to have type synonyms in TcTyConAppCo
- - the first arg of a TcAppCo can be a TcTyConAppCo
- Reason: they'll get established when we desugar to Coercion
-
-\begin{code}
-data TcCoercion
- = TcRefl TcType
- | TcTyConAppCo TyCon [TcCoercion]
- | TcAppCo TcCoercion TcCoercion
- | TcForAllCo TyVar TcCoercion
- | TcInstCo TcCoercion TcType
- | TcCoVarCo EqVar
- | TcAxiomInstCo CoAxiom [TcType]
- | TcSymCo TcCoercion
- | TcTransCo TcCoercion TcCoercion
- | TcNthCo Int TcCoercion
- | TcLetCo TcEvBinds TcCoercion
- deriving (Data.Data, Data.Typeable)
-
-isEqVar :: Var -> Bool
--- Is lifted coercion variable (only!)
-isEqVar v = case tyConAppTyCon_maybe (varType v) of
- Just tc -> tc `hasKey` eqTyConKey
- Nothing -> False
-
-isTcReflCo_maybe :: TcCoercion -> Maybe TcType
-isTcReflCo_maybe (TcRefl ty) = Just ty
-isTcReflCo_maybe _ = Nothing
-
-isTcReflCo :: TcCoercion -> Bool
-isTcReflCo (TcRefl {}) = True
-isTcReflCo _ = False
-
-getTcCoVar_maybe :: TcCoercion -> Maybe CoVar
-getTcCoVar_maybe (TcCoVarCo v) = Just v
-getTcCoVar_maybe _ = Nothing
-
-mkTcReflCo :: TcType -> TcCoercion
-mkTcReflCo = TcRefl
-
-mkTcFunCo :: TcCoercion -> TcCoercion -> TcCoercion
-mkTcFunCo co1 co2 = mkTcTyConAppCo funTyCon [co1, co2]
-
-mkTcTyConAppCo :: TyCon -> [TcCoercion] -> TcCoercion
-mkTcTyConAppCo tc cos -- No need to expand type synonyms
- -- See Note [TcCoercions]
- | Just tys <- traverse isTcReflCo_maybe cos
- = TcRefl (mkTyConApp tc tys) -- See Note [Refl invariant]
-
- | otherwise = TcTyConAppCo tc cos
-
-mkTcAxInstCo :: CoAxiom -> [TcType] -> TcCoercion
-mkTcAxInstCo ax tys
- | arity == n_tys = TcAxiomInstCo ax tys
- | otherwise = ASSERT( arity < n_tys )
- foldl TcAppCo (TcAxiomInstCo ax (take arity tys))
- (map TcRefl (drop arity tys))
- where
- n_tys = length tys
- arity = coAxiomArity ax
-
-mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion
--- No need to deal with TyConApp on the left; see Note [TcCoercions]
-mkTcAppCo (TcRefl ty1) (TcRefl ty2) = TcRefl (mkAppTy ty1 ty2)
-mkTcAppCo co1 co2 = TcAppCo co1 co2
-
-mkTcSymCo :: TcCoercion -> TcCoercion
-mkTcSymCo co@(TcRefl {}) = co
-mkTcSymCo (TcSymCo co) = co
-mkTcSymCo co = TcSymCo co
-
-mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion
-mkTcTransCo (TcRefl _) co = co
-mkTcTransCo co (TcRefl _) = co
-mkTcTransCo co1 co2 = TcTransCo co1 co2
-
-mkTcNthCo :: Int -> TcCoercion -> TcCoercion
-mkTcNthCo n (TcRefl ty) = TcRefl (tyConAppArgN n ty)
-mkTcNthCo n co = TcNthCo n co
-
-mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion
-mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys
-
-mkTcForAllCo :: Var -> TcCoercion -> TcCoercion
--- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkTcForAllCo tv (TcRefl ty) = ASSERT( isTyVar tv ) TcRefl (mkForAllTy tv ty)
-mkTcForAllCo tv co = ASSERT( isTyVar tv ) TcForAllCo tv co
-
-mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion
-mkTcForAllCos tvs (TcRefl ty) = ASSERT( all isTyVar tvs ) TcRefl (mkForAllTys tvs ty)
-mkTcForAllCos tvs co = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs
-
-mkTcInstCos :: TcCoercion -> [TcType] -> TcCoercion
-mkTcInstCos (TcRefl ty) tys = TcRefl (applyTys ty tys)
-mkTcInstCos co tys = foldl TcInstCo co tys
-
-mkTcCoVarCo :: EqVar -> TcCoercion
--- ipv :: s ~ t (the boxed equality type)
-mkTcCoVarCo ipv
- | ty1 `eqType` ty2 = TcRefl ty1
- | otherwise = TcCoVarCo ipv
- where
- (ty1, ty2) = case getEqPredTys_maybe (varType ipv) of
- Nothing -> pprPanic "mkCoVarLCo" (ppr ipv)
- Just tys -> tys
-\end{code}
-
-\begin{code}
-tcCoercionKind :: TcCoercion -> Pair Type
-tcCoercionKind co = go co
- where
- go (TcRefl ty) = Pair ty ty
- go (TcLetCo _ co) = go co
- go (TcTyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos)
- go (TcAppCo co1 co2) = mkAppTy <$> go co1 <*> go co2
- go (TcForAllCo tv co) = mkForAllTy tv <$> go co
- go (TcInstCo co ty) = go_inst co [ty]
- go (TcCoVarCo cv) = eqVarKind cv
- go (TcAxiomInstCo ax tys) = Pair (substTyWith (co_ax_tvs ax) tys (co_ax_lhs ax))
- (substTyWith (co_ax_tvs ax) tys (co_ax_rhs ax))
- go (TcSymCo co) = swap $ go co
- go (TcTransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2)
- go (TcNthCo d co) = tyConAppArgN d <$> go co
-
- -- c.f. Coercion.coercionKind
- go_inst (TcInstCo co ty) tys = go_inst co (ty:tys)
- go_inst co tys = (`applyTys` tys) <$> go co
-
-eqVarKind :: EqVar -> Pair Type
-eqVarKind cv
- | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv)
- = ASSERT (tc `hasKey` eqTyConKey)
- Pair ty1 ty2
- | otherwise = panic "eqVarKind, non coercion variable"
-
-coVarsOfTcCo :: TcCoercion -> VarSet
--- Only works on *zonked* coercions, because of TcLetCo
-coVarsOfTcCo tc_co
- = go tc_co
- where
- go (TcRefl _) = emptyVarSet
- go (TcTyConAppCo _ cos) = foldr (unionVarSet . go) emptyVarSet cos
- go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2
- go (TcForAllCo _ co) = go co
- go (TcInstCo co _) = go co
- go (TcCoVarCo v) = unitVarSet v
- go (TcAxiomInstCo {}) = emptyVarSet
- go (TcSymCo co) = go co
- go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2
- go (TcNthCo _ co) = go co
- go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs
- `minusVarSet` get_bndrs bs
- go (TcLetCo {}) = pprPanic "coVarsOfTcCo called on non-zonked TcCoercion" (ppr tc_co)
-
- -- We expect only coercion bindings
- go_bind :: EvBind -> VarSet
- go_bind (EvBind _ (EvCoercion co)) = go co
- go_bind (EvBind _ (EvId v)) = unitVarSet v
- go_bind other = pprPanic "coVarsOfTcCo:Bind" (ppr other)
-
- get_bndrs :: Bag EvBind -> VarSet
- get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet
-
-liftTcCoSubstWith :: [TyVar] -> [TcCoercion] -> TcType -> TcCoercion
--- This version can ignore capture; the free varialbes of the
--- TcCoerion are all fresh. Result is mush simpler code
-liftTcCoSubstWith tvs cos ty
- = ASSERT( equalLength tvs cos )
- go ty
- where
- env = zipVarEnv tvs cos
-
- go ty@(TyVarTy tv) = case lookupVarEnv env tv of
- Just co -> co
- Nothing -> mkTcReflCo ty
- go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2)
- go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)
- go (ForAllTy tv ty) = mkTcForAllCo tv (go ty)
- go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2)
-\end{code}
-
-Pretty printing
-
-\begin{code}
-instance Outputable TcCoercion where
- ppr = pprTcCo
-
-pprTcCo, pprParendTcCo :: TcCoercion -> SDoc
-pprTcCo co = ppr_co TopPrec co
-pprParendTcCo co = ppr_co TyConPrec co
-
-ppr_co :: Prec -> TcCoercion -> SDoc
-ppr_co _ (TcRefl ty) = angleBrackets (ppr ty)
-
-ppr_co p co@(TcTyConAppCo tc [_,_])
- | tc `hasKey` funTyConKey = ppr_fun_co p co
-
-ppr_co p (TcTyConAppCo tc cos) = pprTcApp p ppr_co tc cos
-ppr_co p (TcLetCo bs co) = maybeParen p TopPrec $
- sep [ptext (sLit "let") <+> braces (ppr bs), ppr co]
-ppr_co p (TcAppCo co1 co2) = maybeParen p TyConPrec $
- pprTcCo co1 <+> ppr_co TyConPrec co2
-ppr_co p co@(TcForAllCo {}) = ppr_forall_co p co
-ppr_co p (TcInstCo co ty) = maybeParen p TyConPrec $
- pprParendTcCo co <> ptext (sLit "@") <> pprType ty
-
-ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv)
-ppr_co p (TcAxiomInstCo con cos) = pprTypeNameApp p ppr_type (getName con) cos
-
-ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $
- ppr_co FunPrec co1
- <+> ptext (sLit ";")
- <+> ppr_co FunPrec co2
-ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co]
-ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co]
-
-ppr_fun_co :: Prec -> TcCoercion -> SDoc
-ppr_fun_co p co = pprArrowChain p (split co)
- where
- split :: TcCoercion -> [SDoc]
- split (TcTyConAppCo f [arg,res])
- | f `hasKey` funTyConKey
- = ppr_co FunPrec arg : split res
- split co = [ppr_co TopPrec co]
-
-ppr_forall_co :: Prec -> TcCoercion -> SDoc
-ppr_forall_co p ty
- = maybeParen p FunPrec $
- sep [pprForAll tvs, ppr_co TopPrec rho]
- where
- (tvs, rho) = split1 [] ty
- split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty
- split1 tvs ty = (reverse tvs, ty)
-\end{code}
-
-%************************************************************************
-%* *
- HsWrapper
-%* *
-%************************************************************************
-
-\begin{code}
-data HsWrapper
- = WpHole -- The identity coercion
-
- | WpCompose HsWrapper HsWrapper
- -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]]
- --
- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. [])
- -- But ([] a) `WpCompose` ([] b) = ([] b a)
-
- | WpCast TcCoercion -- A cast: [] `cast` co
- -- Guaranteed not the identity coercion
-
- -- Evidence abstraction and application
- -- (both dictionaries and coercions)
- | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable
- | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint
-
- -- Kind and Type abstraction and application
- | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var)
- | WpTyApp KindOrType -- [] t the 't' is a type (not coercion)
-
-
- | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
- -- so that the identity coercion is always exactly WpHole
- deriving (Data.Data, Data.Typeable)
-
-
-(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
-WpHole <.> c = c
-c <.> WpHole = c
-c1 <.> c2 = c1 `WpCompose` c2
-
-mkWpTyApps :: [Type] -> HsWrapper
-mkWpTyApps tys = mk_co_app_fn WpTyApp tys
-
-mkWpEvApps :: [EvTerm] -> HsWrapper
-mkWpEvApps args = mk_co_app_fn WpEvApp args
-
-mkWpEvVarApps :: [EvVar] -> HsWrapper
-mkWpEvVarApps vs = mkWpEvApps (map EvId vs)
-
-mkWpTyLams :: [TyVar] -> HsWrapper
-mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
-
-mkWpLams :: [Var] -> HsWrapper
-mkWpLams ids = mk_co_lam_fn WpEvLam ids
-
-mkWpLet :: TcEvBinds -> HsWrapper
--- This no-op is a quite a common case
-mkWpLet (EvBinds b) | isEmptyBag b = WpHole
-mkWpLet ev_binds = WpLet ev_binds
-
-mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as
-
-mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
--- For applications, the *first* argument must
--- come *last* in the composition sequence
-mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as
-
-idHsWrapper :: HsWrapper
-idHsWrapper = WpHole
-
-isIdHsWrapper :: HsWrapper -> Bool
-isIdHsWrapper WpHole = True
-isIdHsWrapper _ = False
-\end{code}
-
-
-%************************************************************************
-%* *
- Evidence bindings
-%* *
-%************************************************************************
-
-\begin{code}
-data TcEvBinds
- = TcEvBinds -- Mutable evidence bindings
- EvBindsVar -- Mutable because they are updated "later"
- -- when an implication constraint is solved
-
- | EvBinds -- Immutable after zonking
- (Bag EvBind)
-
- deriving( Data.Typeable )
-
-data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
- -- The Unique is only for debug printing
-
-instance Data.Data TcEvBinds where
- -- Placeholder; we can't travers into TcEvBinds
- toConstr _ = abstractConstr "TcEvBinds"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = Data.mkNoRepType "TcEvBinds"
-
------------------
-newtype EvBindMap
- = EvBindMap {
- ev_bind_varenv :: VarEnv EvBind
- } -- Map from evidence variables to evidence terms
-
-emptyEvBindMap :: EvBindMap
-emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
-
-extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
-extendEvBinds bs v t
- = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }
-
-lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
-lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
-
-evBindMapBinds :: EvBindMap -> Bag EvBind
-evBindMapBinds bs
- = foldVarEnv consBag emptyBag (ev_bind_varenv bs)
-
------------------
--- All evidence is bound by EvBinds; no side effects
-data EvBind = EvBind EvVar EvTerm
-
-data EvTerm
- = EvId EvId -- Term-level variable-to-variable bindings
- -- (no coercion variables! they come via EvCoercion)
-
- | EvCoercion TcCoercion -- (Boxed) coercion bindings
-
- | EvCast EvVar TcCoercion -- d |> co
-
- | EvDFunApp DFunId -- Dictionary instance application
- [Type] [EvVar]
-
- | EvTupleSel EvId Int -- n'th component of the tuple
-
- | EvTupleMk [EvId] -- tuple built from this stuff
-
- | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
- -- dictionaries, even though the former have no
- -- selector Id. We count up from _0_
-
- deriving( Data.Data, Data.Typeable)
-\end{code}
-
-Note [EvBinds/EvTerm]
-~~~~~~~~~~~~~~~~~~~~~
-How evidence is created and updated. Bindings for dictionaries,
-and coercions and implicit parameters are carried around in TcEvBinds
-which during constraint generation and simplification is always of the
-form (TcEvBinds ref). After constraint simplification is finished it
-will be transformed to t an (EvBinds ev_bag).
-
-Evidence for coercions *SHOULD* be filled in using the TcEvBinds
-However, all EvVars that correspond to *wanted* coercion terms in
-an EvBind must be mutable variables so that they can be readily
-inlined (by zonking) after constraint simplification is finished.
-
-Conclusion: a new wanted coercion variable should be made mutable.
-[Notice though that evidence variables that bind coercion terms
- from super classes will be "given" and hence rigid]
-
-
-\begin{code}
-mkEvCast :: EvVar -> TcCoercion -> EvTerm
-mkEvCast ev lco
- | isTcReflCo lco = EvId ev
- | otherwise = EvCast ev lco
-
-emptyTcEvBinds :: TcEvBinds
-emptyTcEvBinds = EvBinds emptyBag
-
-isEmptyTcEvBinds :: TcEvBinds -> Bool
-isEmptyTcEvBinds (EvBinds b) = isEmptyBag b
-isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
-
-
-evVarsOfTerm :: EvTerm -> [EvVar]
-evVarsOfTerm (EvId v) = [v]
-evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvDFunApp _ _ evs) = evs
-evVarsOfTerm (EvTupleSel v _) = [v]
-evVarsOfTerm (EvSuperClass v _) = [v]
-evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvTupleMk evs) = evs
-\end{code}
-
-
-%************************************************************************
-%* *
- Pretty printing
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable HsWrapper where
- ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
-
-pprHsWrapper :: SDoc -> HsWrapper -> SDoc
--- In debug mode, print the wrapper
--- otherwise just print what's inside
-pprHsWrapper doc wrap
- = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc)
- where
- help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
- -- True <=> appears in function application position
- -- False <=> appears as body of let or lambda
- help it WpHole = it
- help it (WpCompose f1 f2) = help (help it f2) f1
- help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
- <+> pprParendTcCo co)]
- help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
- help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
- help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
- help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False]
- help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False]
-
- pp_bndr v = pprBndr LambdaBind v <> dot
-
- add_parens, no_parens :: SDoc -> Bool -> SDoc
- add_parens d True = parens d
- add_parens d False = d
- no_parens d _ = d
-
-instance Outputable TcEvBinds where
- ppr (TcEvBinds v) = ppr v
- ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs)))
-
-instance Outputable EvBindsVar where
- ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
-
-instance Outputable EvBind where
- ppr (EvBind v e) = sep [ ppr v, nest 2 $ equals <+> ppr e ]
- -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
-
-instance Outputable EvTerm where
- ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
- ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
- ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n))
- ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
- ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
- ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
-\end{code}
-
+% +% (c) The University of Glasgow 2006 +% + +\begin{code} +module TcEvidence ( + + -- HsWrapper + HsWrapper(..), + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpLams, mkWpLet, + idHsWrapper, isIdHsWrapper, pprHsWrapper, + + -- Evidence bindin + TcEvBinds(..), EvBindsVar(..), + EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds, + + EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, + + EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast, + + -- TcCoercion + TcCoercion(..), + mkTcReflCo, mkTcTyConAppCo, mkTcAppCo, mkTcAppCos, mkTcFunCo, + mkTcAxInstCo, mkTcForAllCo, mkTcForAllCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcInstCos, + tcCoercionKind, coVarsOfTcCo, isEqVar, mkTcCoVarCo, + isTcReflCo, isTcReflCo_maybe, getTcCoVar_maybe, + liftTcCoSubstWith + + ) where +#include "HsVersions.h" + +import Var + +import PprCore () -- Instance OutputableBndr TyVar +import TypeRep -- Knows type representation +import TcType +import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe ) +import TysPrim( funTyCon ) +import TyCon +import PrelNames +import VarEnv +import VarSet +import Name + +import Util +import Bag +import Pair +import Control.Applicative +import Data.Traversable (traverse, sequenceA) +import qualified Data.Data as Data +import Outputable +import FastString +import Data.IORef( IORef ) +\end{code} + + +Note [TcCoercions] +~~~~~~~~~~~~~~~~~~ +| LCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An LCoercion is simply a Coercion whose free variables have the +boxed type (a ~ b). After we are done with typechecking the +desugarer finds the free variables, unboxes them, and creates a +resulting real Coercion with kosher free variables. + +We can use most of the Coercion "smart constructors" to build LCoercions. However, +mkCoVarCo will not work! The equivalent is mkTcCoVarCo. + +The data type is similar to Coercion.Coercion, with the following +differences + * Most important, TcLetCo adds let-bindings for coercions. + This is what lets us unify two for-all types and generate + equality constraints underneath + + * The kind of a TcCoercion is t1 ~ t2 + of a Coercion is t1 ~# t2 + + * TcAxiomInstCo takes Types, not Coecions as arguments; + the generality is required only in the Simplifier + + * UnsafeCo aren't required + + * Reprsentation invariants are weaker: + - we are allowed to have type synonyms in TcTyConAppCo + - the first arg of a TcAppCo can be a TcTyConAppCo + Reason: they'll get established when we desugar to Coercion + +\begin{code} +data TcCoercion + = TcRefl TcType + | TcTyConAppCo TyCon [TcCoercion] + | TcAppCo TcCoercion TcCoercion + | TcForAllCo TyVar TcCoercion + | TcInstCo TcCoercion TcType + | TcCoVarCo EqVar + | TcAxiomInstCo CoAxiom [TcType] + | TcSymCo TcCoercion + | TcTransCo TcCoercion TcCoercion + | TcNthCo Int TcCoercion + | TcLetCo TcEvBinds TcCoercion + deriving (Data.Data, Data.Typeable) + +isEqVar :: Var -> Bool +-- Is lifted coercion variable (only!) +isEqVar v = case tyConAppTyCon_maybe (varType v) of + Just tc -> tc `hasKey` eqTyConKey + Nothing -> False + +isTcReflCo_maybe :: TcCoercion -> Maybe TcType +isTcReflCo_maybe (TcRefl ty) = Just ty +isTcReflCo_maybe _ = Nothing + +isTcReflCo :: TcCoercion -> Bool +isTcReflCo (TcRefl {}) = True +isTcReflCo _ = False + +getTcCoVar_maybe :: TcCoercion -> Maybe CoVar +getTcCoVar_maybe (TcCoVarCo v) = Just v +getTcCoVar_maybe _ = Nothing + +mkTcReflCo :: TcType -> TcCoercion +mkTcReflCo = TcRefl + +mkTcFunCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcFunCo co1 co2 = mkTcTyConAppCo funTyCon [co1, co2] + +mkTcTyConAppCo :: TyCon -> [TcCoercion] -> TcCoercion +mkTcTyConAppCo tc cos -- No need to expand type synonyms + -- See Note [TcCoercions] + | Just tys <- traverse isTcReflCo_maybe cos + = TcRefl (mkTyConApp tc tys) -- See Note [Refl invariant] + + | otherwise = TcTyConAppCo tc cos + +mkTcAxInstCo :: CoAxiom -> [TcType] -> TcCoercion +mkTcAxInstCo ax tys + | arity == n_tys = TcAxiomInstCo ax tys + | otherwise = ASSERT( arity < n_tys ) + foldl TcAppCo (TcAxiomInstCo ax (take arity tys)) + (map TcRefl (drop arity tys)) + where + n_tys = length tys + arity = coAxiomArity ax + +mkTcAppCo :: TcCoercion -> TcCoercion -> TcCoercion +-- No need to deal with TyConApp on the left; see Note [TcCoercions] +mkTcAppCo (TcRefl ty1) (TcRefl ty2) = TcRefl (mkAppTy ty1 ty2) +mkTcAppCo co1 co2 = TcAppCo co1 co2 + +mkTcSymCo :: TcCoercion -> TcCoercion +mkTcSymCo co@(TcRefl {}) = co +mkTcSymCo (TcSymCo co) = co +mkTcSymCo co = TcSymCo co + +mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcTransCo (TcRefl _) co = co +mkTcTransCo co (TcRefl _) = co +mkTcTransCo co1 co2 = TcTransCo co1 co2 + +mkTcNthCo :: Int -> TcCoercion -> TcCoercion +mkTcNthCo n (TcRefl ty) = TcRefl (tyConAppArgN n ty) +mkTcNthCo n co = TcNthCo n co + +mkTcAppCos :: TcCoercion -> [TcCoercion] -> TcCoercion +mkTcAppCos co1 tys = foldl mkTcAppCo co1 tys + +mkTcForAllCo :: Var -> TcCoercion -> TcCoercion +-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) +mkTcForAllCo tv (TcRefl ty) = ASSERT( isTyVar tv ) TcRefl (mkForAllTy tv ty) +mkTcForAllCo tv co = ASSERT( isTyVar tv ) TcForAllCo tv co + +mkTcForAllCos :: [Var] -> TcCoercion -> TcCoercion +mkTcForAllCos tvs (TcRefl ty) = ASSERT( all isTyVar tvs ) TcRefl (mkForAllTys tvs ty) +mkTcForAllCos tvs co = ASSERT( all isTyVar tvs ) foldr TcForAllCo co tvs + +mkTcInstCos :: TcCoercion -> [TcType] -> TcCoercion +mkTcInstCos (TcRefl ty) tys = TcRefl (applyTys ty tys) +mkTcInstCos co tys = foldl TcInstCo co tys + +mkTcCoVarCo :: EqVar -> TcCoercion +-- ipv :: s ~ t (the boxed equality type) +mkTcCoVarCo ipv + | ty1 `eqType` ty2 = TcRefl ty1 + | otherwise = TcCoVarCo ipv + where + (ty1, ty2) = case getEqPredTys_maybe (varType ipv) of + Nothing -> pprPanic "mkCoVarLCo" (ppr ipv) + Just tys -> tys +\end{code} + +\begin{code} +tcCoercionKind :: TcCoercion -> Pair Type +tcCoercionKind co = go co + where + go (TcRefl ty) = Pair ty ty + go (TcLetCo _ co) = go co + go (TcTyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) + go (TcAppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go (TcForAllCo tv co) = mkForAllTy tv <$> go co + go (TcInstCo co ty) = go_inst co [ty] + go (TcCoVarCo cv) = eqVarKind cv + go (TcAxiomInstCo ax tys) = Pair (substTyWith (co_ax_tvs ax) tys (co_ax_lhs ax)) + (substTyWith (co_ax_tvs ax) tys (co_ax_rhs ax)) + go (TcSymCo co) = swap $ go co + go (TcTransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go (TcNthCo d co) = tyConAppArgN d <$> go co + + -- c.f. Coercion.coercionKind + go_inst (TcInstCo co ty) tys = go_inst co (ty:tys) + go_inst co tys = (`applyTys` tys) <$> go co + +eqVarKind :: EqVar -> Pair Type +eqVarKind cv + | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv) + = ASSERT (tc `hasKey` eqTyConKey) + Pair ty1 ty2 + | otherwise = panic "eqVarKind, non coercion variable" + +coVarsOfTcCo :: TcCoercion -> VarSet +-- Only works on *zonked* coercions, because of TcLetCo +coVarsOfTcCo tc_co + = go tc_co + where + go (TcRefl _) = emptyVarSet + go (TcTyConAppCo _ cos) = foldr (unionVarSet . go) emptyVarSet cos + go (TcAppCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcForAllCo _ co) = go co + go (TcInstCo co _) = go co + go (TcCoVarCo v) = unitVarSet v + go (TcAxiomInstCo {}) = emptyVarSet + go (TcSymCo co) = go co + go (TcTransCo co1 co2) = go co1 `unionVarSet` go co2 + go (TcNthCo _ co) = go co + go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs + `minusVarSet` get_bndrs bs + go (TcLetCo {}) = pprPanic "coVarsOfTcCo called on non-zonked TcCoercion" (ppr tc_co) + + -- We expect only coercion bindings + go_bind :: EvBind -> VarSet + go_bind (EvBind _ (EvCoercion co)) = go co + go_bind (EvBind _ (EvId v)) = unitVarSet v + go_bind other = pprPanic "coVarsOfTcCo:Bind" (ppr other) + + get_bndrs :: Bag EvBind -> VarSet + get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet + +liftTcCoSubstWith :: [TyVar] -> [TcCoercion] -> TcType -> TcCoercion +-- This version can ignore capture; the free varialbes of the +-- TcCoerion are all fresh. Result is mush simpler code +liftTcCoSubstWith tvs cos ty + = ASSERT( equalLength tvs cos ) + go ty + where + env = zipVarEnv tvs cos + + go ty@(TyVarTy tv) = case lookupVarEnv env tv of + Just co -> co + Nothing -> mkTcReflCo ty + go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2) + go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys) + go (ForAllTy tv ty) = mkTcForAllCo tv (go ty) + go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2) +\end{code} + +Pretty printing + +\begin{code} +instance Outputable TcCoercion where + ppr = pprTcCo + +pprTcCo, pprParendTcCo :: TcCoercion -> SDoc +pprTcCo co = ppr_co TopPrec co +pprParendTcCo co = ppr_co TyConPrec co + +ppr_co :: Prec -> TcCoercion -> SDoc +ppr_co _ (TcRefl ty) = angleBrackets (ppr ty) + +ppr_co p co@(TcTyConAppCo tc [_,_]) + | tc `hasKey` funTyConKey = ppr_fun_co p co + +ppr_co p (TcTyConAppCo tc cos) = pprTcApp p ppr_co tc cos +ppr_co p (TcLetCo bs co) = maybeParen p TopPrec $ + sep [ptext (sLit "let") <+> braces (ppr bs), ppr co] +ppr_co p (TcAppCo co1 co2) = maybeParen p TyConPrec $ + pprTcCo co1 <+> ppr_co TyConPrec co2 +ppr_co p co@(TcForAllCo {}) = ppr_forall_co p co +ppr_co p (TcInstCo co ty) = maybeParen p TyConPrec $ + pprParendTcCo co <> ptext (sLit "@") <> pprType ty + +ppr_co _ (TcCoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) +ppr_co p (TcAxiomInstCo con cos) = pprTypeNameApp p ppr_type (getName con) cos + +ppr_co p (TcTransCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 + <+> ptext (sLit ";") + <+> ppr_co FunPrec co2 +ppr_co p (TcSymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendTcCo co] +ppr_co p (TcNthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendTcCo co] + +ppr_fun_co :: Prec -> TcCoercion -> SDoc +ppr_fun_co p co = pprArrowChain p (split co) + where + split :: TcCoercion -> [SDoc] + split (TcTyConAppCo f [arg,res]) + | f `hasKey` funTyConKey + = ppr_co FunPrec arg : split res + split co = [ppr_co TopPrec co] + +ppr_forall_co :: Prec -> TcCoercion -> SDoc +ppr_forall_co p ty + = maybeParen p FunPrec $ + sep [pprForAll tvs, ppr_co TopPrec rho] + where + (tvs, rho) = split1 [] ty + split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) +\end{code} + +%************************************************************************ +%* * + HsWrapper +%* * +%************************************************************************ + +\begin{code} +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] + -- + -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) + -- But ([] a) `WpCompose` ([] b) = ([] b a) + + | WpCast TcCoercion -- A cast: [] `cast` co + -- Guaranteed not the identity coercion + + -- Evidence abstraction and application + -- (both dictionaries and coercions) + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) + + + | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + -- so that the identity coercion is always exactly WpHole + deriving (Data.Data, Data.Typeable) + + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_app_fn WpTyApp tys + +mkWpEvApps :: [EvTerm] -> HsWrapper +mkWpEvApps args = mk_co_app_fn WpEvApp args + +mkWpEvVarApps :: [EvVar] -> HsWrapper +mkWpEvVarApps vs = mkWpEvApps (map EvId vs) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_lam_fn WpTyLam ids + +mkWpLams :: [Var] -> HsWrapper +mkWpLams ids = mk_co_lam_fn WpEvLam ids + +mkWpLet :: TcEvBinds -> HsWrapper +-- This no-op is a quite a common case +mkWpLet (EvBinds b) | isEmptyBag b = WpHole +mkWpLet ev_binds = WpLet ev_binds + +mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as + +mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +-- For applications, the *first* argument must +-- come *last* in the composition sequence +mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as + +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper _ = False +\end{code} + + +%************************************************************************ +%* * + Evidence bindings +%* * +%************************************************************************ + +\begin{code} +data TcEvBinds + = TcEvBinds -- Mutable evidence bindings + EvBindsVar -- Mutable because they are updated "later" + -- when an implication constraint is solved + + | EvBinds -- Immutable after zonking + (Bag EvBind) + + deriving( Data.Typeable ) + +data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique + -- The Unique is only for debug printing + +instance Data.Data TcEvBinds where + -- Placeholder; we can't travers into TcEvBinds + toConstr _ = abstractConstr "TcEvBinds" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "TcEvBinds" + +----------------- +newtype EvBindMap + = EvBindMap { + ev_bind_varenv :: VarEnv EvBind + } -- Map from evidence variables to evidence terms + +emptyEvBindMap :: EvBindMap +emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv } + +extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap +extendEvBinds bs v t + = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) } + +lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind +lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs) + +evBindMapBinds :: EvBindMap -> Bag EvBind +evBindMapBinds bs + = foldVarEnv consBag emptyBag (ev_bind_varenv bs) + +----------------- +-- All evidence is bound by EvBinds; no side effects +data EvBind = EvBind EvVar EvTerm + +data EvTerm + = EvId EvId -- Term-level variable-to-variable bindings + -- (no coercion variables! they come via EvCoercion) + + | EvCoercion TcCoercion -- (Boxed) coercion bindings + + | EvCast EvVar TcCoercion -- d |> co + + | EvDFunApp DFunId -- Dictionary instance application + [Type] [EvVar] + + | EvTupleSel EvId Int -- n'th component of the tuple + + | EvTupleMk [EvId] -- tuple built from this stuff + + | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors + -- See Note [Deferring coercion errors to runtime] + -- in TcSimplify + + | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and + -- dictionaries, even though the former have no + -- selector Id. We count up from _0_ + | EvKindCast EvVar TcCoercion -- See Note [EvKindCast] + + deriving( Data.Data, Data.Typeable) +\end{code} + +Note [EvKindCast] +~~~~~~~~~~~~~~~~~ + +EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2) +but the kinds of s1 and s2 (k1 and k2 respectively) don't match but +are rather equal by a coercion. You may think that this coercion will +always turn out to be ReflCo, so why is this needed? Because sometimes +we will want to defer kind errors until the runtime and in these cases +that coercion will be an 'error' term, which we want to evaluate rather +than silently forget about! + +The relevant (and only) place where such a coercion is produced in +the simplifier is in emit_kind_constraint in TcCanonical. + + +Note [EvBinds/EvTerm] +~~~~~~~~~~~~~~~~~~~~~ +How evidence is created and updated. Bindings for dictionaries, +and coercions and implicit parameters are carried around in TcEvBinds +which during constraint generation and simplification is always of the +form (TcEvBinds ref). After constraint simplification is finished it +will be transformed to t an (EvBinds ev_bag). + +Evidence for coercions *SHOULD* be filled in using the TcEvBinds +However, all EvVars that correspond to *wanted* coercion terms in +an EvBind must be mutable variables so that they can be readily +inlined (by zonking) after constraint simplification is finished. + +Conclusion: a new wanted coercion variable should be made mutable. +[Notice though that evidence variables that bind coercion terms + from super classes will be "given" and hence rigid] + + +\begin{code} +mkEvCast :: EvVar -> TcCoercion -> EvTerm +mkEvCast ev lco + | isTcReflCo lco = EvId ev + | otherwise = EvCast ev lco + +mkEvKindCast :: EvVar -> TcCoercion -> EvTerm +mkEvKindCast ev lco + | isTcReflCo lco = EvId ev + | otherwise = EvKindCast ev lco + +emptyTcEvBinds :: TcEvBinds +emptyTcEvBinds = EvBinds emptyBag + +isEmptyTcEvBinds :: TcEvBinds -> Bool +isEmptyTcEvBinds (EvBinds b) = isEmptyBag b +isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" + + +evVarsOfTerm :: EvTerm -> [EvVar] +evVarsOfTerm (EvId v) = [v] +evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co) +evVarsOfTerm (EvDFunApp _ _ evs) = evs +evVarsOfTerm (EvTupleSel v _) = [v] +evVarsOfTerm (EvSuperClass v _) = [v] +evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co) +evVarsOfTerm (EvTupleMk evs) = evs +evVarsOfTerm (EvDelayedError _ _) = [] +evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co) +\end{code} + + +%************************************************************************ +%* * + Pretty printing +%* * +%************************************************************************ + +\begin{code} +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn + +pprHsWrapper :: SDoc -> HsWrapper -> SDoc +-- In debug mode, print the wrapper +-- otherwise just print what's inside +pprHsWrapper doc wrap + = getPprStyle (\ s -> if debugStyle s then (help (add_parens doc) wrap False) else doc) + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") + <+> pprParendTcCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] + help it (WpTyLam tv) = add_parens $ sep [ptext (sLit "/\\") <> pp_bndr tv, it False] + help it (WpLet binds) = add_parens $ sep [ptext (sLit "let") <+> braces (ppr binds), it False] + + pp_bndr v = pprBndr LambdaBind v <> dot + + add_parens, no_parens :: SDoc -> Bool -> SDoc + add_parens d True = parens d + add_parens d False = d + no_parens d _ = d + +instance Outputable TcEvBinds where + ppr (TcEvBinds v) = ppr v + ppr (EvBinds bs) = ptext (sLit "EvBinds") <> braces (vcat (map ppr (bagToList bs))) + +instance Outputable EvBindsVar where + ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u) + +instance Outputable EvBind where + ppr (EvBind v e) = sep [ ppr v, nest 2 $ equals <+> ppr e ] + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + +instance Outputable EvTerm where + ppr (EvId v) = ppr v + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co + ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) + ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs + ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] + ppr (EvDelayedError ty msg) = ptext (sLit "error") + <+> sep [ char '@' <> ppr ty, ppr msg ] +\end{code} + diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 340b33c749..abcff85d7d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -31,7 +31,8 @@ import TcUnify import BasicTypes import Inst import TcBinds -import FamInst( tcLookupFamInst ) +import FamInst ( tcLookupFamInst ) +import FamInstEnv ( famInstAxiom, dataFamInstRepTyCon ) import TcEnv import TcArrows import TcMatches @@ -324,7 +325,7 @@ tcExpr (SectionR op arg2) res_ty tcExpr (SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDOpts -- Note [Left sections] + ; dflags <- getDynFlags -- Note [Left sections] ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 | otherwise = 2 @@ -1159,12 +1160,12 @@ tcTagToEnum loc fun_name arg res_ty = do { mb_fam <- tcLookupFamInst tc tc_args ; case mb_fam of Nothing -> failWithTc (tagToEnumError ty doc3) - Just (rep_tc, rep_args) + Just (rep_fam, rep_args) -> return ( mkTcSymCo (mkTcAxInstCo co_tc rep_args) , rep_tc, rep_args ) where - co_tc = expectJust "tcTagToEnum" $ - tyConFamilyCoercion_maybe rep_tc } + co_tc = famInstAxiom rep_fam + rep_tc = dataFamInstRepTyCon rep_fam } tagToEnumError :: TcType -> SDoc -> SDoc tagToEnumError ty what @@ -1394,7 +1395,7 @@ funAppCtxt fun arg arg_no 2 (quotes (ppr arg)) funResCtxt :: LHsExpr Name -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, Message) + -> TidyEnv -> TcM (TidyEnv, MsgDoc) -- When we have a mis-match in the return type of a function -- try to give a helpful message about too many/few arguments funResCtxt fun fun_res_ty res_ty env0 diff --git a/compiler/typecheck/TcExpr.lhs-boot b/compiler/typecheck/TcExpr.lhs-boot index 7bd1e6c5c6..378a012f67 100644 --- a/compiler/typecheck/TcExpr.lhs-boot +++ b/compiler/typecheck/TcExpr.lhs-boot @@ -1,35 +1,28 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcExpr where -import HsSyn ( HsExpr, LHsExpr ) -import Name ( Name ) -import TcType ( TcType, TcRhoType, TcSigmaType ) +import HsSyn ( HsExpr, LHsExpr ) +import Name ( Name ) +import TcType ( TcType, TcRhoType, TcSigmaType ) import TcRnTypes( TcM, TcId, CtOrigin ) tcPolyExpr :: - LHsExpr Name + LHsExpr Name -> TcSigmaType -> TcM (LHsExpr TcId) tcMonoExpr, tcMonoExprNC :: - LHsExpr Name + LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcInferRho, tcInferRhoNC :: - LHsExpr Name + LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) tcSyntaxOp :: CtOrigin - -> HsExpr Name - -> TcType - -> TcM (HsExpr TcId) + -> HsExpr Name + -> TcType + -> TcM (HsExpr TcId) tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) \end{code} diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index c040d6d58f..c009343b32 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -246,14 +246,14 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar check False (illegalForeignTyErr empty sig_ty) return idecl (arg1_ty:arg_tys) -> do - dflags <- getDOpts + dflags <- getDynFlags check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty return idecl | cconv == PrimCallConv = do - dflags <- getDOpts + dflags <- getDynFlags check (xopt Opt_GHCForeignImportPrim dflags) (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.") checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) @@ -268,7 +268,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkCg checkCOrAsmOrLlvmOrDotNetOrInterp checkCConv cconv checkCTarget target - dflags <- getDOpts + dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty @@ -383,7 +383,7 @@ checkForeignRes non_io_result_ok check_safe pred_res_ty ty -- Case for non-IO result type with FFI Import _ -> do - dflags <- getDOpts + dflags <- getDynFlags case (pred_res_ty ty && non_io_result_ok) of -- handle normal typecheck fail, we want to handle this first and -- only report safe haskell errors if the normal type check is OK. @@ -440,7 +440,7 @@ checkCOrAsmOrLlvmOrDotNetOrInterp _ checkCg :: (HscTarget -> Maybe SDoc) -> TcM () checkCg check = do - dflags <- getDOpts + dflags <- getDynFlags let target = hscTarget dflags case target of HscNothing -> return () @@ -456,7 +456,7 @@ Calling conventions checkCConv :: CCallConv -> TcM () checkCConv CCallConv = return () checkCConv CApiConv = return () -checkCConv StdCallConv = do dflags <- getDOpts +checkCConv StdCallConv = do dflags <- getDynFlags let platform = targetPlatform dflags unless (platformArch platform == ArchX86) $ -- This is a warning, not an error. see #3336 @@ -468,7 +468,7 @@ checkCConv CmmCallConv = panic "checkCConv CmmCallConv" Warnings \begin{code} -check :: Bool -> Message -> TcM () +check :: Bool -> MsgDoc -> TcM () check True _ = return () check _ the_err = addErrTc the_err @@ -483,7 +483,7 @@ argument, result :: SDoc argument = text "argument" result = text "result" -badCName :: CLabelString -> Message +badCName :: CLabelString -> MsgDoc badCName target = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 0839e183be..70d841e5ed 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -49,6 +49,7 @@ import Name import HscTypes import PrelInfo +import FamInstEnv( FamInst ) import MkCore ( eRROR_ID ) import PrelNames hiding (error_RDR) import PrimOp @@ -90,7 +91,7 @@ data DerivStuff -- Please add this auxiliary stuff -- Generics | DerivTyCon TyCon -- New data types - | DerivFamInst TyCon -- New type family instances + | DerivFamInst FamInst -- New type family instances -- New top-level auxiliary bindings | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB @@ -1800,8 +1801,8 @@ genAuxBindSpec loc (DerivMaxTag tycon) type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings ( Bag (LHsBind RdrName, LSig RdrName) -- Extra bindings (used by Generic only) - , Bag TyCon -- Extra top-level datatypes - , Bag TyCon -- Extra family instances + , Bag TyCon -- Extra top-level datatypes + , Bag FamInst -- Extra family instances , Bag (InstInfo RdrName)) -- Extra instances genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 126575d45e..1fbb7df856 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -24,9 +24,10 @@ import TcType import TcGenDeriv import DataCon import TyCon -import Name hiding (varName) -import Module (Module, moduleName, moduleNameString) -import IfaceEnv (newGlobalBinder) +import FamInstEnv ( FamInst, mkSynFamInst ) +import Module ( Module, moduleName, moduleNameString ) +import IfaceEnv ( newGlobalBinder ) +import Name hiding ( varName ) import RdrName import BasicTypes import TysWiredIn @@ -70,7 +71,7 @@ gen_Generic_binds tc mod = do `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) `unionBags` metaInsts)) } -genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, TyCon) +genGenericRepExtras :: TyCon -> Module -> TcM (MetaTyCons, FamInst) genGenericRepExtras tc mod = do uniqS <- newUniqueSupply let @@ -99,15 +100,14 @@ genGenericRepExtras tc mod = mkTyCon name = ASSERT( isExternalName name ) buildAlgTyCon name [] [] distinctAbstractTyConRhs - NonRecursive False NoParentTyCon Nothing + NonRecursive False NoParentTyCon - metaDTyCon <- mkTyCon d_name - metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] - metaSTyCons <- mapM sequence - [ [ mkTyCon s_name - | s_name <- s_namesC ] | s_namesC <- s_names ] + let metaDTyCon = mkTyCon d_name + metaCTyCons = map mkTyCon c_names + metaSTyCons = [ [ mkTyCon s_name | s_name <- s_namesC ] + | s_namesC <- s_names ] - let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons + metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons rep0_tycon <- tc_mkRepTyCon tc metaDts mod @@ -117,7 +117,7 @@ genGenericRepExtras tc mod = genDtMeta :: (TyCon, MetaTyCons) -> TcM BagDerivStuff genDtMeta (tc,metaDts) = do loc <- getSrcSpanM - dflags <- getDOpts + dflags <- getDynFlags dClas <- tcLookupClass datatypeClassName let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc d_dfun_name <- new_dfun_name dClas tc @@ -257,7 +257,7 @@ mkBindsRep tycon = tc_mkRepTyCon :: TyCon -- The type to generate representation for -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy - -> TcM TyCon -- Generated representation0 type + -> TcM FamInst -- Generated representation0 coercion tc_mkRepTyCon tycon metaDts mod = -- Consider the example input tycon `D`, where data D a b = D_ a do { -- `rep0` = GHC.Generics.Rep (type family) @@ -269,17 +269,14 @@ tc_mkRepTyCon tycon metaDts mod = -- `rep_name` is a name we generate for the synonym ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon))) (nameSrcSpan (tyConName tycon)) + ; let -- `tyvars` = [a,b] tyvars = tyConTyVars tycon - -- rep0Ty has kind * -> * - rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind - -- `appT` = D a b appT = [mkTyConApp tycon (mkTyVarTys tyvars)] - - ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind - NoParentTyCon (Just (rep0, appT)) } + ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty + } diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index c1f425b2e6..73361aefaa 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -424,7 +424,7 @@ warnMissingSig msg id ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) ; addWarnTcM (env1, mk_msg tidy_ty) } where - mk_msg ty = sep [ msg, nest 2 $ pprHsVar (idName id) <+> dcolon <+> ppr ty ] + mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ] --------------------------------------------- zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id) @@ -792,7 +792,8 @@ zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets, recS_ret_ty = ret_ty }) + , recS_later_rets = later_rets, recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs ; new_ret_ty <- zonkTcTypeToType env ret_ty @@ -803,12 +804,14 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id ; (env2, new_segStmts) <- zonkStmts env1 segStmts -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt - ; new_rets <- mapM (zonkExpr env2) rets + ; new_later_rets <- mapM (zonkExpr env2) later_rets + ; new_rec_rets <- mapM (zonkExpr env2) rec_rets ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> @@ -930,14 +933,23 @@ zonk_pat env (TuplePat pats boxed ty) ; (env', pats') <- zonkPats env pats ; return (env', TuplePat pats' boxed ty') } -zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args }) - = ASSERT( all isImmutableTyVar (pat_tvs p) ) +zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars + , pat_dicts = evs, pat_binds = binds + , pat_args = args }) + = ASSERT( all isImmutableTyVar tyvars ) do { new_ty <- zonkTcTypeToType env ty - ; (env1, new_evs) <- zonkEvBndrsX env evs + ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; (env1, new_evs) <- zonkEvBndrsX env0 evs ; (env2, new_binds) <- zonkTcEvBinds env1 binds ; (env', new_args) <- zonkConStuff env2 args - ; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs, - pat_binds = new_binds, pat_args = new_args }) } + ; returnM (env', p { pat_ty = new_ty, + pat_tvs = new_tyvars, + pat_dicts = new_evs, + pat_binds = new_binds, + pat_args = new_args }) } zonk_pat env (LitPat lit) = return (env, LitPat lit) @@ -1035,15 +1047,22 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) (varSetElemsKvsFirst unbound_tkvs) ++ new_bndrs - ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) } + ; return $ + HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs } where zonk_bndr env (RuleBndr (L loc v)) - = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) } + = do { (env', v') <- zonk_it env v + ; return (env', RuleBndr (L loc v')) } zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" zonk_it env v - | isId v = do { v' <- zonkIdBndr env v; return (extendIdZonkEnv1 env v', v') } - | otherwise = ASSERT( isImmutableTyVar v) return (env, v) + | isId v = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv1 env v', v') } + | otherwise = ASSERT( isImmutableTyVar v) + zonkTyBndrX env v + -- DV: used to be return (env,v) but that is plain + -- wrong because we may need to go inside the kind + -- of v and zonk there! \end{code} \begin{code} @@ -1086,6 +1105,11 @@ zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co zonkEvTerm env (EvCast v co) = ASSERT( isId v) do { co' <- zonkTcLCoToLCo env co ; return (mkEvCast (zonkIdOcc env v) co') } + +zonkEvTerm env (EvKindCast v co) = ASSERT( isId v) + do { co' <- zonkTcLCoToLCo env co + ; return (mkEvKindCast (zonkIdOcc env v) co') } + zonkEvTerm env (EvTupleSel v n) = return (EvTupleSel (zonkIdOcc env v) n) zonkEvTerm env (EvTupleMk vs) = return (EvTupleMk (map (zonkIdOcc env) vs)) zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) @@ -1093,6 +1117,9 @@ zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } +zonkEvTerm env (EvDelayedError ty msg) + = do { ty' <- zonkTcTypeToType env ty + ; return (EvDelayedError ty' msg) } zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 3a35046959..66b74388b3 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -46,7 +46,7 @@ import {-# SOURCE #-} TcSplice( kcSpliceType ) import HsSyn import RnHsSyn import TcRnMonad -import RnEnv ( polyKindsErr ) +import RnEnv ( dataKindsErr ) import TcHsSyn ( mkZonkTcTyVar ) import TcEvidence( HsWrapper ) import TcEnv @@ -59,7 +59,7 @@ import Kind import Var import VarSet import TyCon -import DataCon ( DataCon, dataConUserType ) +import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class import RdrName ( rdrNameSpace, nameRdrName ) @@ -68,11 +68,10 @@ import NameSet import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_PolyKinds ) ) +import DynFlags ( ExtensionFlag( Opt_DataKinds ) ) import Util import UniqSupply import Outputable -import BuildTyCl ( buildPromotedDataTyCon ) import FastString import Control.Monad ( unless ) \end{code} @@ -349,14 +348,10 @@ kc_hs_type (HsParTy ty) exp_kind = do ty' <- kc_lhs_type ty exp_kind return (HsParTy ty') -kc_hs_type (HsTyVar name) exp_kind - -- Special case for the unit tycon so it benefits from kind overloading - | name == tyConName unitTyCon - = kc_hs_type (HsTupleTy HsBoxedOrConstraintTuple []) exp_kind - | otherwise = do - (ty, k) <- kcTyVar name - checkExpectedKind ty k exp_kind - return ty +kc_hs_type (HsTyVar name) exp_kind = do + (ty, k) <- kcTyVar name + checkExpectedKind ty k exp_kind + return ty kc_hs_type (HsListTy ty) exp_kind = do ty' <- kcLiftedType ty @@ -515,12 +510,13 @@ kc_hs_type (HsDocTy ty _) exp_kind kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind = do { ty_k_s <- mapM kc_lhs_type_fresh tys ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKind ty (mkListTy kind) exp_kind + ; checkExpectedKind ty (mkPromotedListTy kind) exp_kind ; return (HsExplicitListTy kind (map fst ty_k_s)) } kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do ty_k_s <- mapM kc_lhs_type_fresh tys - let tupleKi = mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s) + let tycon = promotedTupleTyCon BoxedTuple (length tys) + tupleKi = mkTyConApp tycon (map snd ty_k_s) checkExpectedKind ty tupleKi exp_kind return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) @@ -750,14 +746,14 @@ ds_type (HsExplicitListTy kind tys) = do kind' <- zonkTcKindToKind kind ds_tys <- mapM dsHsType tys return $ - foldr (\a b -> mkTyConApp (buildPromotedDataTyCon consDataCon) [kind', a, b]) - (mkTyConApp (buildPromotedDataTyCon nilDataCon) [kind']) ds_tys + foldr (\a b -> mkTyConApp (buildPromotedDataCon consDataCon) [kind', a, b]) + (mkTyConApp (buildPromotedDataCon nilDataCon) [kind']) ds_tys ds_type (HsExplicitTupleTy kis tys) = do MASSERT( length kis == length tys ) kis' <- mapM zonkTcKindToKind kis tys' <- mapM dsHsType tys - return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') + return $ mkTyConApp (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') ds_type (HsWrapTy (WpKiApps kappas) ty) = do tau <- ds_type ty @@ -812,7 +808,7 @@ ds_var_app name arg_tys = do { thing <- tcLookupGlobal name ; case thing of ATyCon tc -> return (mkTyConApp tc arg_tys) - ADataCon dc -> return (mkTyConApp (buildPromotedDataTyCon dc) arg_tys) + ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) _ -> wrongThingErr "type" (AGlobal thing) name } addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a @@ -1308,13 +1304,14 @@ sc_ds_hs_kind (HsFunTy ki1 ki2) = sc_ds_hs_kind (HsListTy ki) = do kappa <- sc_ds_lhs_kind ki checkWiredInTyCon listTyCon - return $ mkListTy kappa + return $ mkPromotedListTy kappa sc_ds_hs_kind (HsTupleTy _ kis) = do kappas <- mapM sc_ds_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas - where tycon = tupleTyCon BoxedTuple (length kis) + where + tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) @@ -1331,15 +1328,16 @@ sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> -- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar sc_ds_var_app :: Name -> [Kind] -> TcM Kind -- Special case for * and Constraint kinds +-- They are kinds already, so we don't need to promote them sc_ds_var_app name arg_kis - | name == liftedTypeKindTyConName - || name == constraintKindTyConName = do - unless (null arg_kis) - (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) - thing <- tcLookup name - case thing of - AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" + | name == liftedTypeKindTyConName + || name == constraintKindTyConName + = do { unless (null arg_kis) + (failWithTc (text "Kind" <+> ppr name <+> text "cannot be applied")) + ; thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) -> return (mkTyConApp tc []) + _ -> panic "sc_ds_var_app 1" } -- General case sc_ds_var_app name arg_kis = do @@ -1347,24 +1345,25 @@ sc_ds_var_app name arg_kis = do case mb_thing of Just (AGlobal (ATyCon tc)) | isAlgTyCon tc || isTupleTyCon tc -> do - poly_kinds <- xoptM Opt_PolyKinds - unless poly_kinds $ addErr (polyKindsErr name) - let tc_kind = tyConKind tc - case isPromotableKind tc_kind of + data_kinds <- xoptM Opt_DataKinds + unless data_kinds $ addErr (dataKindsErr name) + case isPromotableTyCon tc of Just n | n == length arg_kis -> - return (mkTyConApp (mkPromotedTypeTyCon tc) arg_kis) - Just _ -> err tc_kind "is not fully applied" - Nothing -> err tc_kind "is not promotable" + return (mkTyConApp (buildPromotedTyCon tc) arg_kis) + Just _ -> err tc "is not fully applied" + Nothing -> err tc "is not promotable" + -- It is in scope, but not what we expected Just thing -> wrongThingErr "promoted type" thing name + -- It is not in scope, but it passed the renamer: staging error Nothing -> ASSERT2 ( isTyConName name, ppr name ) failWithTc (ptext (sLit "Promoted kind") <+> quotes (ppr name) <+> ptext (sLit "used in a mutually recursive group")) - - where err k m = failWithTc ( quotes (ppr name) <+> ptext (sLit "of kind") - <+> quotes (ppr k) <+> ptext (sLit m)) + where + err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind") + <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg)) \end{code} diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 1eaf927ffd..89a034ba18 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -42,7 +42,7 @@ import DataCon import Class import Var import VarEnv -import VarSet ( mkVarSet, varSetElems ) +import VarSet ( mkVarSet, subVarSet, varSetElems ) import Pair import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) @@ -61,7 +61,6 @@ import SrcLoc import Util import Control.Monad -import Data.Maybe import Maybes ( orElse ) \end{code} @@ -367,40 +366,29 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls tcInstDecls1 tycl_decls inst_decls deriv_decls = checkNoErrs $ - do { -- Stop if addInstInfos etc discovers any errors - -- (they recover, so that we get more than one error each - -- round) - - -- (1) Do class and family instance declarations - ; idx_tycons <- mapAndRecoverM tcTopFamInstDecl $ - filter (isFamInstDecl . unLoc) tycl_decls - ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls - - ; let { (local_info, - at_tycons_s) = unzip local_info_tycons - ; at_idx_tycons = concat at_tycons_s ++ idx_tycons - ; at_things = map ATyCon at_idx_tycons } - - -- (2) Add the tycons of indexed types and their implicit - -- tythings to the global environment - ; tcExtendGlobalEnvImplicit at_things $ do - { tcg_env <- tcAddImplicits at_things - ; setGblEnv tcg_env $ - - - -- Next, construct the instance environment so far, consisting - -- of - -- (a) local instance decls - -- (b) local family instance decls - addInsts local_info $ - addFamInsts at_idx_tycons $ do { - - -- (3) Compute instances from "deriving" clauses; - -- This stuff computes a context for the derived instance - -- decl, so it needs to know about all the instances possible - -- NB: class instance declarations can contain derivings as - -- part of associated data type declarations - failIfErrsM -- If the addInsts stuff gave any errors, don't + do { -- Stop if addInstInfos etc discovers any errors + -- (they recover, so that we get more than one error each + -- round) + + -- (1) Do class and family instance declarations + ; inst_decl_stuff <- mapAndRecoverM tcLocalInstDecl1 inst_decls + + ; let { (local_infos_s, fam_insts_s) = unzip inst_decl_stuff + ; all_fam_insts = concat fam_insts_s + ; local_infos = concat local_infos_s } + + -- (2) Next, construct the instance environment so far, consisting of + -- (a) local instance decls + -- (b) local family instance decls + ; addClsInsts local_infos $ + addFamInsts all_fam_insts $ do + + -- (3) Compute instances from "deriving" clauses; + -- This stuff computes a context for the derived instance + -- decl, so it needs to know about all the instances possible + -- NB: class instance declarations can contain derivings as + -- part of associated data type declarations + { failIfErrsM -- If the addInsts stuff gave any errors, don't -- try the deriving stuff, because that may give -- more errors still @@ -410,41 +398,56 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- Check that if the module is compiled with -XSafe, there are no -- hand written instances of Typeable as then unsafe casts could be -- performed. Derived instances are OK. - ; dflags <- getDOpts + ; dflags <- getDynFlags ; when (safeLanguageOn dflags) $ mapM_ (\x -> when (typInstCheck x) (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_info + local_infos -- As above but for Safe Inference mode. ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_info + mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos ; return ( gbl_env - , (bagToList deriv_inst_info) ++ local_info + , bagToList deriv_inst_info ++ local_infos , deriv_binds) - }}} + }} where typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" ++ " Haskell! Can only derive them" -addInsts :: [InstInfo Name] -> TcM a -> TcM a -addInsts infos thing_inside +addClsInsts :: [InstInfo Name] -> TcM a -> TcM a +addClsInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [TyCon] -> TcM a -> TcM a -addFamInsts tycons thing_inside - = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside +addFamInsts :: [FamInst] -> TcM a -> TcM a +-- Extend (a) the family instance envt +-- (b) the type envt with stuff from data type decls +addFamInsts fam_insts thing_inside + = tcExtendLocalFamInstEnv fam_insts $ + tcExtendGlobalEnvImplicit things $ + do { tcg_env <- tcAddImplicits things + ; setGblEnv tcg_env thing_inside } + where + axioms = map famInstAxiom fam_insts + tycons = famInstsRepTyCons fam_insts + things = map ATyCon tycons ++ map ACoAxiom axioms \end{code} \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM (InstInfo Name, [TyCon]) + -> TcM ([InstInfo Name], [FamInst]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context -tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) +tcLocalInstDecl1 (L loc (FamInstDecl decl)) + = setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { fam_inst <- tcFamInstDecl TopLevel decl + ; return ([], [fam_inst]) } + +tcLocalInstDecl1 (L loc (ClsInstDecl poly_ty binds uprags ats)) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -453,40 +456,45 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) badBootDeclErr ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty - ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - + ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) + mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + -- Next, process any associated types. ; traceTc "tcLocalInstDecl" (ppr poly_ty) - ; idx_tycons0 <- tcExtendTyVarEnv tyvars $ - mapAndRecoverM (tcAssocDecl clas mini_env) ats + ; fam_insts0 <- tcExtendTyVarEnv tyvars $ + mapAndRecoverM (tcAssocDecl clas mini_env) ats -- Check for missing associated types and build them -- from their defaults (if available) ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats - check_at_instance (fam_tc, defs) + + mk_deflt_at_instances :: ClassATItem -> TcM [FamInst] + mk_deflt_at_instances (fam_tc, defs) -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats = return (Nothing, []) + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + -- No defaults ==> generate a warning - | null defs = return (Just (tyConName fam_tc), []) + | null defs + = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) + ; return [] } + -- No user instance, have defaults ==> instatiate them - | otherwise = do - defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do - let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env - tvs' = varSetElems (tyVarsOfType rhs') - pat_tys' = substTys mini_env_subst pat_tys - rhs' = substTy mini_env_subst rhs - rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - buildSynTyCon rep_tc_name tvs' - (SynonymTyCon rhs') - (mkArrowKinds (map tyVarKind tvs') (typeKind rhs')) - NoParentTyCon (Just (fam_tc, pat_tys')) - return (Nothing, defs') - ; missing_at_stuff <- mapM check_at_instance (classATItems clas) + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | otherwise + = forM defs $ \(ATD _tvs pat_tys rhs _loc) -> + do { let pat_tys' = substTys mini_subst pat_tys + rhs' = substTy mini_subst rhs + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElems tv_set' + ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + return (mkSynFamInst rep_tc_name tvs' fam_tc pat_tys' rhs') } + + ; fam_insts1 <- mapM mk_deflt_at_instances (classATItems clas) - ; let (omitted, idx_tycons1) = unzip missing_at_stuff - ; warn <- woptM Opt_WarnMissingMethods - ; mapM_ (warnTc warn . omittedATWarn) (catMaybes omitted) - -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) @@ -497,10 +505,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ispec = mkLocalInstance dfun overlap_flag inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False } - ; return (inst_info, idx_tycons0 ++ concat idx_tycons1) } + ; return ( [inst_info], fam_insts0 ++ concat fam_insts1) } \end{code} - %************************************************************************ %* * Type checking family instances @@ -513,15 +520,9 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcTopFamInstDecl :: LTyClDecl Name -> TcM TyCon -tcTopFamInstDecl (L loc decl) - = setSrcSpan loc $ - tcAddDeclCtxt decl $ - tcFamInstDecl TopLevel decl - -tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon +tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM FamInst tcFamInstDecl top_lvl decl - = do { -- type family instances require -XTypeFamilies + = do { -- Type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file ; traceTc "tcFamInstDecl" (ppr decl) ; let fam_tc_lname = tcdLName decl @@ -539,13 +540,9 @@ tcFamInstDecl top_lvl decl -- Now check the type/data instance itself -- This is where type and data decls are treated separately - ; tc <- tcFamInstDecl1 fam_tc decl - ; checkValidTyCon tc -- Remember to check validity; - -- no recursion to worry about here + ; tcFamInstDecl1 fam_tc decl } - ; return tc } - -tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon +tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM FamInst -- "type instance" tcFamInstDecl1 fam_tc (decl@TySynonym {}) @@ -556,17 +553,14 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {}) ; checkValidFamInst t_typats t_rhs -- (3) construct representation tycon - ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats - ; buildSynTyCon rep_tc_name t_tvs - (SynonymTyCon t_rhs) - (typeKind t_rhs) - NoParentTyCon (Just (fam_tc, t_typats)) - } + ; rep_tc_name <- newFamInstAxiomName (tcdLName decl) t_typats + + ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) } -- "newtype instance" and "data instance" tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt , tcdTyVars = tvs, tcdTyPats = Just pats - , tcdCons = cons}) + , tcdCons = cons}) = do { -- Check that the family declaration is for the right kind checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) @@ -588,27 +582,33 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt -- Construct representation tycon ; rep_tc_name <- newFamInstTyConName (tcdLName decl) pats' + ; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc ; let ex_ok = True -- Existentials ok for type families! - ; fixM (\ rep_tycon -> do - { let orig_res_ty = mkTyConApp fam_tc pats' - ; data_cons <- tcConDecls new_or_data ex_ok rep_tycon + orig_res_ty = mkTyConApp fam_tc pats' + + ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) -> + do { data_cons <- tcConDecls new_or_data ex_ok rec_rep_tc (tvs', orig_res_ty) cons - ; tc_rhs <- - case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) - ; buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs Recursive - h98_syntax NoParentTyCon (Just (fam_tc, pats')) + ; tc_rhs <- case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) + ; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc + parent = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats' + rep_tc = buildAlgTyCon rep_tc_name tvs' stupid_theta tc_rhs + Recursive h98_syntax parent -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. - }) - } } + ; return (rep_tc, fam_inst) } + + -- Remember to check validity; no recursion to worry about here + ; checkValidTyCon rep_tc + ; return fam_inst } } where - h98_syntax = case cons of -- All constructors have same shape + h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False _ -> True @@ -619,26 +619,28 @@ tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d) tcAssocDecl :: Class -- ^ Class of associated type -> VarEnv Type -- ^ Instantiation of class TyVars -> LTyClDecl Name -- ^ RHS - -> TcM TyCon + -> TcM FamInst tcAssocDecl clas mini_env (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ - do { at_tc <- tcFamInstDecl NotTopLevel decl - ; let Just (fam_tc, at_tys) = tyConFamInst_maybe at_tc - + do { fam_inst <- tcFamInstDecl NotTopLevel decl + ; let (fam_tc, at_tys) = famInstLHS fam_inst + -- Check that the associated type comes from this class ; checkTc (Just clas == tyConAssoc_maybe fam_tc) - (badATErr (className clas) (tyConName at_tc)) + (badATErr (className clas) (tyConName fam_tc)) -- See Note [Checking consistent instantiation] in TcTyClsDecls ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys - ; return at_tc } + ; return fam_inst } where check_arg fam_tc_tv at_ty | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv = checkTc (inst_ty `eqType` at_ty) (wrongATArgErr at_ty inst_ty) + -- No need to instantiate here, becuase the axiom + -- uses the same type variables as the assocated class | otherwise = return () -- Allow non-type-variable instantiation -- See Note [Associated type instances] @@ -713,7 +715,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] - ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds + ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods ; (meth_ids, meth_binds) @@ -722,7 +724,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Those tyvars are inside the dfun_id's type, which is a bit -- bizarre, but OK so long as you realise it! tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars - inst_tys spec_info + inst_tys spec_inst_info op_items ibinds -- Create the result bindings @@ -773,7 +775,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) map Var meth_ids export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun - , abe_mono = self_dict, abe_prags = SpecPrags spec_inst_prags } + , abe_mono = self_dict, abe_prags = noSpecPrags } + -- NB: noSpecPrags, see Note [SPECIALISE instance pragmas] main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] @@ -892,16 +895,12 @@ Consider range (x,y) = ... We do *not* want to make a specialised version of the dictionary -function. Rather, we want specialised versions of each method. +function. Rather, we want specialised versions of each *method*. Thus we should generate something like this: - $dfIx :: (Ix a, Ix x) => Ix (a,b) - {- DFUN [$crange, ...] -} - $dfIx da db = Ix ($crange da db) (...other methods...) - - $dfIxPair :: (Ix a, Ix x) => Ix (a,b) + $dfIxPair :: (Ix a, Ix b) => Ix (a,b) {- DFUN [$crangePair, ...] -} - $dfIxPair = Ix ($crangePair da db) (...other methods...) + $dfIxPair da db = Ix ($crangePair da db) (...other methods...) $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} @@ -1007,7 +1006,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_default sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) - ; warnMissingMethod sel_id + ; warnMissingMethodOrAT "method" (idName sel_id) ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; return (meth_id, mkVarBind meth_id $ @@ -1064,14 +1063,22 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags -- Adapt the SPECIALISE pragmas to work for this method Id -- There are two sources: - -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-} - -- These ones have the dfun inside, but [perhaps surprisingly] - -- the correct wrapper -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} + -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-} + -- These ones have the dfun inside, but [perhaps surprisingly] + -- the correct wrapper. mk_meth_spec_prags meth_id spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ - [ L loc (SpecPrag meth_id wrap inl) - | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) + = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) + where + spec_prags_from_inst + | isInlinePragma (idInlinePragma meth_id) + = [] -- Do not inherit SPECIALISE from the instance if the + -- method is marked INLINE, because then it'll be inlined + -- and the specialisation would do nothing. (Indeed it'll provoke + -- a warning from the desugarer + | otherwise + = [ L loc (SpecPrag meth_id wrap inl) + | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] loc = getSrcSpan dfun_id sig_fn = mkSigFun sigs @@ -1194,18 +1201,15 @@ derivBindCtxt sel_id clas tys _bind <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] --- Too voluminous --- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] - -warnMissingMethod :: Id -> TcM () -warnMissingMethod sel_id +warnMissingMethodOrAT :: String -> Name -> TcM () +warnMissingMethodOrAT what name = do { warn <- woptM Opt_WarnMissingMethods - ; traceTc "warn" (ppr sel_id <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName sel_id)))) + ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name)))) ; warnTc (warn -- Warn only if -fwarn-missing-methods - && not (startsWithUnderscore (getOccName sel_id))) + && not (startsWithUnderscore (getOccName name))) -- Don't warn about _foo methods - (ptext (sLit "No explicit method nor default method for") - <+> quotes (ppr sel_id)) } + (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for") + <+> quotes (ppr name)) } \end{code} Note [Export helper functions] @@ -1331,10 +1335,6 @@ instDeclCtxt2 dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc -omittedATWarn :: Name -> SDoc -omittedATWarn at - = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at) - badBootFamInstDeclErr :: SDoc badBootFamInstDeclErr = ptext (sLit "Illegal family instance in hs-boot file") diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 45e89a8274..3b46af4573 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -7,7 +7,6 @@ -- for details module TcInteract ( - solveInteractWanted, -- Solves [WantedEvVar] solveInteractGiven, -- Solves [EvVar],GivenLoc solveInteractCts, -- Solves [Cts] ) where @@ -20,10 +19,11 @@ import TcCanonical import VarSet import Type import Unify +import FamInstEnv +import Coercion( mkAxInstRHS ) import Id import Var -import VarEnv ( ) -- unitVarEnv, mkInScopeSet import TcType @@ -37,6 +37,8 @@ import FunDeps import TcEvidence import Outputable +import TcMType ( zonkTcPredType ) + import TcRnTypes import TcErrors import TcSMonad @@ -96,25 +98,44 @@ solveInteractCts cts ; setTcSEvVarCacheMap new_evvar_cache ; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract } - where add_cts_in_cache evvar_cache = foldM solve_or_cache ([],evvar_cache) - solve_or_cache :: ([Ct],TypeMap (EvVar,CtFlavor)) - -> Ct - -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) - solve_or_cache (acc_cts,acc_cache) ct - | isIPPred pty - = return (ct:acc_cts,acc_cache) -- Do not use the cache, - -- nor update it for IPPreds due to subtle shadowing - | Just (ev',fl') <- lookupTM pty acc_cache - , fl' `canSolve` fl - , isWanted fl - = do { _ <- setEvBind ev (EvId ev') fl - ; return (acc_cts,acc_cache) } - | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! - = return (ct:acc_cts, alterTM pty (\_ -> Just (ev,fl)) acc_cache) - where fl = cc_flavor ct - ev = cc_id ct - pty = ctPred ct - + where + add_cts_in_cache evvar_cache cts + = do { ctxt <- getTcSContext + ; foldM (solve_or_cache (simplEqsOnly ctxt)) ([],evvar_cache) cts } + + solve_or_cache :: Bool -- Solve equalities only, not classes etc + -> ([Ct],TypeMap (EvVar,CtFlavor)) + -> Ct + -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) + solve_or_cache eqs_only (acc_cts,acc_cache) ct + | dont_cache eqs_only (classifyPredType pred_ty) + = return (ct:acc_cts,acc_cache) + + | Just (ev',fl') <- lookupTM pred_ty acc_cache + , fl' `canSolve` fl + , isWanted fl + = do { _ <- setEvBind ev (EvId ev') fl + ; return (acc_cts,acc_cache) } + + | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! + = return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache) + where fl = cc_flavor ct + ev = cc_id ct + pred_ty = ctPred ct + + dont_cache :: Bool -> PredTree -> Bool + -- Do not use the cache, not update it, if this is true + dont_cache _ (IPPred {}) = True -- IPPreds have subtle shadowing + dont_cache _ (EqPred ty1 ty2) -- Report Int ~ Bool errors separately + | Just tc1 <- tyConAppTyCon_maybe ty1 + , Just tc2 <- tyConAppTyCon_maybe ty2 + , tc1 /= tc2 + = isDecomposableTyCon tc1 && isDecomposableTyCon tc2 + | otherwise = False + dont_cache eqs_only _ = eqs_only + -- If we are simplifying equalities only, + -- do not cache non-equalities + -- See Note [Simplifying RULE lhs constraints] in TcSimplify solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () solveInteractGiven gloc evs @@ -123,14 +144,6 @@ solveInteractGiven gloc evs , cc_flavor = Given gloc GivenOrig , cc_depth = 0 } -solveInteractWanted :: [WantedEvVar] -> TcS () --- Solve these wanteds along with current inerts and wanteds! -solveInteractWanted wevs - = solveInteractCts (map mk_noncan wevs) - where mk_noncan (EvVarX v w) - = CNonCanonical { cc_id = v, cc_flavor = Wanted w, cc_depth = 0 } - - -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- solveInteract :: TcS () @@ -146,7 +159,7 @@ solveInteract NoWorkRemaining -- Done, successfuly (modulo frozen) -> return () MaxDepthExceeded ct -- Failure, depth exceeded - -> solverDepthErrorTcS (cc_depth ct) [ct] + -> wrapErrTcS $ solverDepthErrorTcS (cc_depth ct) [ct] NextWorkItem ct -- More work, loop around! -> runSolverPipeline thePipeline ct >> solve_loop } ; solve_loop } @@ -431,7 +444,16 @@ kick_out_rewritable ct (IS { inert_eqs = eqmap (fro_out, fro_in) = partitionBag rewritable frozen rewritable ct = (fl `canRewrite` cc_flavor ct) && - (tv `elemVarSet` tyVarsOfCt ct) + (tv `elemVarSet` tyVarsOfCt ct) + -- NB: tyVarsOfCt will return the type + -- variables /and the kind variables/ that are + -- directly visible in the type. Hence we will + -- have exposed all the rewriting we care about + -- to make the most precise kinds visible for + -- matching classes etc. No need to kick out + -- constraints that mention type variables whose + -- kinds could contain this variable! + \end{code} Note [Delicate equality kick-out] @@ -500,15 +522,9 @@ trySpontaneousSolve _ = return SPCantSolve trySpontaneousEqOneWay :: SubGoalDepth -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable -trySpontaneousEqOneWay d eqv gw tv xi - | not (isSigTyVar tv) || isTyVarTy xi - = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts - -- so we have its more specific kind in our hands - ; is_sub_kind <- kxi `isSubKindTcS` tyVarKind tv - ; if is_sub_kind then - solveWithIdentity d eqv gw tv xi - else return SPCantSolve - } +trySpontaneousEqOneWay d eqv gw tv xi + | not (isSigTyVar tv) || isTyVarTy xi + = solveWithIdentity d eqv gw tv xi | otherwise -- Still can't solve, sig tyvar and non-variable rhs = return SPCantSolve @@ -518,13 +534,10 @@ trySpontaneousEqTwoWay :: SubGoalDepth -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here trySpontaneousEqTwoWay d eqv gw tv1 tv2 - = do { k1_sub_k2 <- k1 `isSubKindTcS` k2 + = do { let k1_sub_k2 = k1 `isSubKind` k2 ; if k1_sub_k2 && nicer_to_update_tv2 then solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1) - else do - { k2_sub_k1 <- k2 `isSubKindTcS` k1 - ; MASSERT( k2_sub_k1 ) -- they were unified in TcCanonical - ; solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } } + else solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } where k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -771,7 +784,6 @@ doInteractWithInert , text "Inert item=" <+> ppr inertItem ] - -- Two pieces of irreducible evidence: if their types are *exactly identical* we can -- rewrite them. We can never improve using this: if we want ty1 :: Constraint and have -- ty2 :: Constraint it clearly does not mean that (ty1 ~ ty2) @@ -1262,6 +1274,116 @@ When we react a family instance with a type family equation in the work list we keep the synonym-using RHS without expansion. +%************************************************************************ +%* * +%* Functional dependencies, instantiation of equations +%* * +%************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see Trac #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of FunDeps.lhs (nicer +now!). + +\begin{code} +rewriteWithFunDeps :: [Equation] + -> [Xi] + -> WantedLoc + -> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)])) + -- Not quite a WantedEvVar unfortunately + -- Because our intention could be to make + -- it derived at the end of the day +-- NB: The flavor of the returned EvVars will be decided by the caller +-- Post: returns no trivial equalities (identities) and all EvVars returned are fresh +rewriteWithFunDeps eqn_pred_locs xis wloc + = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs + ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))] + fd_ev_pos = concat fd_ev_poss + (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) + ; if null fd_ev_pos then return Nothing + else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) } + +instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] +-- Post: Returns the position index as well as the corresponding FunDep equality +instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs + , fd_pred1 = d1, fd_pred2 = d2 }) + = do { let tvs = varSetElems qtvs + ; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution + ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') + ; foldM (do_one subst) [] eqs } + where + do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) + = let sty1 = Type.substTy subst ty1 + sty2 = Type.substTy subst ty2 + in if eqType sty1 sty2 then return ievs -- Return no trivial equalities + else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds + ; let wl' = push_ctx wl + ; if isNewEvVar eqv then + return $ (i,(evc_the_evvar eqv,wl')):ievs + else -- We are eventually going to emit FD work back in the work list so + -- it is important that we only return the /freshly created/ and not + -- some existing equality! + return ievs } + + push_ctx :: WantedLoc -> WantedLoc + push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc + +mkEqnMsg :: (TcPredType, SDoc) + -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) +mkEqnMsg (pred1,from1) (pred2,from2) tidy_env + = do { zpred1 <- zonkTcPredType pred1 + ; zpred2 <- zonkTcPredType pred2 + ; let { tpred1 = tidyType tidy_env zpred1 + ; tpred2 = tidyType tidy_env zpred2 } + ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), + nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), + nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] + ; return (tidy_env, msg) } + +rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) + -> [Type] -- A sequence of types: tys + -> [(Type, TcCoercion)] -- Returns: [(ty', co : ty' ~ ty)] +rewriteDictParams param_eqs tys + = zipWith do_one tys [0..] + where + do_one :: Type -> Int -> (Type, TcCoercion) + do_one ty n = case lookup n param_eqs of + Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev)) + Nothing -> (ty, mkTcReflCo ty) -- Identity + + get_fst_ty (wev,_wloc) + | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev ) + = ty1 + | otherwise + = panic "rewriteDictParams: non equality fundep!?" + + +emitFDWorkAsDerived :: [(EvVar,WantedLoc)] + -> SubGoalDepth -> TcS () +emitFDWorkAsDerived evlocs d + = updWorkListTcS $ appendWorkListEqs fd_cts + where fd_cts = map mk_fd_ct evlocs + mk_fd_ct (v,wl) = CNonCanonical { cc_id = v + , cc_flavor = Derived wl + , cc_depth = d } + + +\end{code} + + + + ********************************************************************************* * * The top-reaction Stage @@ -1331,7 +1453,9 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc -- Wanted dictionary doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) - , cc_class = cls, cc_tyargs = xis }) + , cc_id = dict_id + , cc_class = cls, cc_tyargs = xis + , cc_depth = depth }) -- See Note [MATCHING-SYNONYMS] = do { traceTcS "doTopReact" (ppr workItem) ; instEnvs <- getInstEnvs @@ -1345,7 +1469,7 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) do { lkup_inst_res <- matchClassInst inerts cls xis loc ; case lkup_inst_res of GenInst wtvs ev_term - -> doSolveFromInstance wtvs ev_term workItem + -> doSolveFromInstance wtvs ev_term NoInstance -> return NoTopInt } @@ -1355,31 +1479,26 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" , tir_new_item = ContinueWith workItem } } } - where doSolveFromInstance :: [WantedEvVar] - -> EvTerm - -> Ct - -> TcS TopInteractResult + where doSolveFromInstance :: [EvVar] -> EvTerm -> TcS TopInteractResult -- Precondition: evidence term matches the predicate of cc_id of workItem - doSolveFromInstance wtvs ev_term workItem - | null wtvs - = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem)) - ; _ <- setEvBind (cc_id workItem) ev_term fl + doSolveFromInstance evs ev_term + | null evs + = do { traceTcS "doTopReact/found nullary instance for" (ppr dict_id) + ; _ <- setEvBind dict_id ev_term fl ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" , tir_new_item = Stop } } -- Don't put him in the inerts | otherwise - = do { traceTcS "doTopReact/found non-nullary instance for" $ - ppr (cc_id workItem) - ; _ <- setEvBind (cc_id workItem) ev_term fl + = do { traceTcS "doTopReact/found non-nullary instance for" (ppr dict_id) + ; _ <- setEvBind dict_id ev_term fl -- Solved and new wanted work produced, you may cache the -- (tentatively solved) dictionary as Solved given. -- ; let _solved = workItem { cc_flavor = solved_fl } -- solved_fl = mkSolvedFlavor fl UnkSkol - ; let ct_from_wev (EvVarX v fl) - = CNonCanonical { cc_id = v, cc_flavor = Wanted fl - , cc_depth = cc_depth workItem + 1 } - wtvs_cts = map ct_from_wev wtvs - ; updWorkListTcS (appendWorkListCt wtvs_cts) + ; let mk_new_wanted ev + = CNonCanonical { cc_id = ev, cc_flavor = fl + , cc_depth = depth + 1 } + ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } @@ -1396,16 +1515,12 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl , cc_fun = tc, cc_tyargs = args, cc_rhs = xi }) = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] - ; case match_res of + ; case match_res of Nothing -> return NoTopInt - Just (rep_tc, rep_tys) - -> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc - Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys) - -- Eagerly expand away the type synonym on the - -- RHS of a type function, so that it never - -- appears in an error message - -- See Note [Type synonym families] in TyCon - coe = mkTcAxInstCo coe_tc rep_tys + Just (famInst, rep_tys) + -> do { let coe_ax = famInstAxiom famInst + rhs_ty = mkAxInstRHS coe_ax rep_tys + coe = mkTcAxInstCo coe_ax rep_tys ; case fl of Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version ; let eqv' = evc_the_evvar evc @@ -1434,7 +1549,6 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl , cc_flavor = fl' , cc_depth = cc_depth workItem + 1} ; updWorkListTcS (extendWorkListEq ct) - ; return $ SomeTopInt { tir_rule = "Fun/Top (given)" , tir_new_item = ContinueWith workItem } } @@ -1500,6 +1614,7 @@ Then it is solvable, but its very hard to detect this on the spot. It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. + Note [When improvement happens] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We fire an improvement rule when @@ -1655,7 +1770,7 @@ NB: The desugarer needs be more clever to deal with equalities \begin{code} data LookupInstResult = NoInstance - | GenInst [WantedEvVar] EvTerm + | GenInst [EvVar] EvTerm matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult matchClassInst inerts clas tys loc @@ -1690,10 +1805,9 @@ matchClassInst inerts clas tys loc else do { evc_vars <- instDFunConstraints theta (Wanted loc) ; let ev_vars = map evc_the_evvar evc_vars - new_evc_vars = filter isNewEvVar evc_vars - wevs = map (\v -> EvVarX (evc_the_evvar v) loc) new_evc_vars - -- wevs are only the real new variables that can be emitted - ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } + new_ev_vars = [evc_the_evvar evc | evc <- evc_vars, isNewEvVar evc] + -- new_ev_vars are only the real new variables that can be emitted + ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } } } where diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 2bbb2e11eb..f63ec5125f 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -66,9 +66,8 @@ module TcMType ( zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWantedEvVar, + zonkImplication, zonkEvVar, zonkWC, - zonkWC, zonkWantedEvVars, zonkTcTypeAndSubst, tcGetGlobalTyVars, @@ -549,7 +548,8 @@ zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty where zonk_tv tv = do { z_tv <- updateTyVarKindM zonkTcKind tv - ; case tcTyVarDetails tv of + ; ASSERT ( isTcTyVar tv ) + case tcTyVarDetails tv of SkolemTv {} -> return (TyVarTy z_tv) RuntimeUnk {} -> return (TyVarTy z_tv) FlatSkol ty -> zonkType zonk_tv ty @@ -694,12 +694,6 @@ zonkCt ct zonkCts :: Cts -> TcM Cts zonkCts = mapBagM zonkCt -zonkWantedEvVars :: Bag WantedEvVar -> TcM (Bag WantedEvVar) -zonkWantedEvVars = mapBagM zonkWantedEvVar - -zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar -zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) } - zonkFlavor :: CtFlavor -> TcM CtFlavor zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } zonkFlavor fl = return fl @@ -1186,7 +1180,7 @@ check_valid_theta :: UserTypeCtxt -> [PredType] -> TcM () check_valid_theta _ [] = return () check_valid_theta ctxt theta = do - dflags <- getDOpts + dflags <- getDynFlags warnTc (notNull dups) (dupPredWarn dups) mapM_ (check_pred_ty dflags ctxt) theta where @@ -1493,7 +1487,7 @@ We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () checkValidInstHead ctxt clas tys - = do { dflags <- getDOpts + = do { dflags <- getDynFlags -- Check language restrictions; -- but not for SPECIALISE isntance pragmas @@ -1624,7 +1618,7 @@ The underlying idea is that \begin{code} -checkInstTermination :: [TcType] -> ThetaType -> [Message] +checkInstTermination :: [TcType] -> ThetaType -> [MsgDoc] checkInstTermination tys theta = mapCatMaybes check theta where @@ -1681,7 +1675,7 @@ checkValidFamInst typats rhs -- checkFamInstRhs :: [Type] -- lhs -> [(TyCon, [Type])] -- type family instances - -> [Message] + -> [MsgDoc] checkFamInstRhs lhsTys famInsts = mapCatMaybes check famInsts where diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index d09e384834..acdc8389be 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -31,6 +31,7 @@ import TcMType import TcType import TcBinds import TcUnify +import TcErrors ( misMatchMsg ) import Name import TysWiredIn import Id @@ -803,7 +804,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys - tup_ty = mkBoxedTupleTy tup_elt_tys + tup_ty = mkBigCoreTupTy tup_elt_tys ; tcExtendIdEnv tup_ids $ do { stmts_ty <- newFlexiTyVarTy liftedTypeKind @@ -832,7 +833,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing) + , recS_later_rets = [], recS_rec_rets = tup_rets + , recS_ret_ty = stmts_ty }, thing) }} tcDoStmt _ stmt _ _ @@ -875,5 +877,22 @@ checkArgs fun (MatchGroup (match1:matches) _) args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty + +failWithMisMatch :: [EqOrigin] -> TcM a +-- Generate the message when two types fail to match, +-- going to some trouble to make it helpful. +-- We take the failing types from the top of the origin stack +-- rather than reporting the particular ones we are looking +-- at right now +failWithMisMatch (item:origin) + = wrapEqCtxt origin $ + do { ty_act <- zonkTcType (uo_actual item) + ; ty_exp <- zonkTcType (uo_expected item) + ; env0 <- tcInitTidyEnv + ; let (env1, pp_exp) = tidyOpenType env0 ty_exp + (env2, pp_act) = tidyOpenType env1 ty_act + ; failWithTcM (env2, misMatchMsg True pp_exp pp_act) } +failWithMisMatch [] + = panic "failWithMisMatch" \end{code} diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot index f898f3deb7..8c421da6da 100644 --- a/compiler/typecheck/TcMatches.lhs-boot +++ b/compiler/typecheck/TcMatches.lhs-boot @@ -1,24 +1,17 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcMatches where -import HsSyn ( GRHSs, MatchGroup ) +import HsSyn ( GRHSs, MatchGroup ) import TcEvidence( HsWrapper ) -import Name ( Name ) -import TcType ( TcRhoType ) +import Name ( Name ) +import TcType ( TcRhoType ) import TcRnTypes( TcM, TcId ) tcGRHSsPat :: GRHSs Name - -> TcRhoType - -> TcM (GRHSs TcId) + -> TcRhoType + -> TcM (GRHSs TcId) tcMatchesFun :: Name -> Bool - -> MatchGroup Name - -> TcRhoType - -> TcM (HsWrapper, MatchGroup TcId) + -> MatchGroup Name + -> TcRhoType + -> TcM (HsWrapper, MatchGroup TcId) \end{code} diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 137df8af7c..f1f502d967 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -761,6 +761,9 @@ matchExpectedConTy data_tc pat_ty = do { (_, tys, subst) <- tcInstTyVars (tyConTyVars data_tc) -- tys = [ty1,ty2] + ; traceTc "matchExpectedConTy" (vcat [ppr data_tc, + ppr (tyConTyVars data_tc), + ppr fam_tc, ppr fam_args]) ; co1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty -- co1 : T (ty1,ty2) ~ pat_ty diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4879974387..8a5aab5437 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -5,26 +5,19 @@ \section[TcMovectle]{Typechecking a whole module} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcRnDriver ( #ifdef GHCI - tcRnStmt, tcRnExpr, tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, + tcRnStmt, tcRnExpr, tcRnType, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, #endif - tcRnLookupName, - tcRnGetInfo, - tcRnModule, - tcTopSrcDecls, - tcRnExtCore + tcRnLookupName, + tcRnGetInfo, + tcRnModule, + tcTopSrcDecls, + tcRnExtCore ) where #ifdef GHCI @@ -47,7 +40,7 @@ import FamInstEnv import TcAnnotations import TcBinds import HeaderInfo ( mkPrelImports ) -import TcType ( tidyTopType ) +import TcType ( tidyTopType ) import TcDefaults import TcEnv import TcRules @@ -84,7 +77,7 @@ import DataCon import Type import Class import TcType ( orphNamesOfDFunHead ) -import Inst ( tcGetInstEnvs ) +import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) import Data.IORef ( readIORef ) @@ -96,7 +89,7 @@ import RnTypes import RnExpr import MkId import BasicTypes -import TidyPgm ( globaliseAndTidyId ) +import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) #endif @@ -111,25 +104,25 @@ import Control.Monad \end{code} %************************************************************************ -%* * - Typecheck and rename a module -%* * +%* * + Typecheck and rename a module +%* * %************************************************************************ \begin{code} -- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> HscSource - -> Bool -- True <=> save renamed syntax +tcRnModule :: HscEnv + -> HscSource + -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages, Maybe TcGblEnv) + -> IO (Messages, Maybe TcGblEnv) tcRnModule hsc_env hsc_src save_rn_syntax HsParsedModule { hpm_module = (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec + import_decls local_decls mod_deprec maybe_doc_hdr)), hpm_src_files = src_files @@ -137,17 +130,17 @@ tcRnModule hsc_env hsc_src save_rn_syntax = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; - (this_mod, prel_imp_loc) + (this_mod, prel_imp_loc) = case maybe_mod of - Nothing -- 'module M where' is omitted - -> (mAIN, srcLocSpan (srcSpanStart loc)) - - Just (L mod_loc mod) -- The normal case + Nothing -- 'module M where' is omitted + -> (mAIN, srcLocSpan (srcSpanStart loc)) + + Just (L mod_loc mod) -- The normal case -> (mkModule this_pkg mod, mod_loc) } ; - - initTc hsc_env hsc_src save_rn_syntax this_mod $ + + initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ - do { -- Deal with imports; first add implicit prelude + do { -- Deal with imports; first add implicit prelude implicit_prelude <- xoptM Opt_ImplicitPrelude; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } ; @@ -155,70 +148,70 @@ tcRnModule hsc_env hsc_src save_rn_syntax ifWOptM Opt_WarnImplicitPrelude $ when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ; - tcg_env <- {-# SCC "tcRnImports" #-} + tcg_env <- {-# SCC "tcRnImports" #-} tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ; - setGblEnv tcg_env $ do { - - -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - -- - -- Do this *after* tcRnImports, so that we know whether - -- a module that we import imports us; and hence whether to - -- look for a hi-boot file - boot_iface <- tcHiBootIface hsc_src this_mod ; - - -- Rename and type check the declarations - traceRn (text "rn1a") ; - tcg_env <- if isHsBoot hsc_src then - tcRnHsBootDecls local_decls - else - {-# SCC "tcRnSrcDecls" #-} + setGblEnv tcg_env $ do { + + -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_iface <- tcHiBootIface hsc_src this_mod ; + + -- Rename and type check the declarations + traceRn (text "rn1a") ; + tcg_env <- if isHsBoot hsc_src then + tcRnHsBootDecls local_decls + else + {-# SCC "tcRnSrcDecls" #-} tcRnSrcDecls boot_iface local_decls ; - setGblEnv tcg_env $ do { - - -- Report the use of any deprecated things - -- We do this *before* processsing the export list so - -- that we don't bleat about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) - -- That is, only uses in the *body* of the module are complained about - traceRn (text "rn3") ; - failIfErrsM ; -- finishWarnings crashes sometimes - -- as a result of typechecker repairs (e.g. unboundNames) - tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; - - -- Process the export list + setGblEnv tcg_env $ do { + + -- Report the use of any deprecated things + -- We do this *before* processsing the export list so + -- that we don't bleat about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + -- That is, only uses in the *body* of the module are complained about + traceRn (text "rn3") ; + failIfErrsM ; -- finishWarnings crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) + tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ; + + -- Process the export list traceRn (text "rn4a: before exports"); - tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4b: after exportss") ; + tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; + traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) checkMainExported tcg_env ; - -- Compare the hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_iface ; + -- Compare the hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_iface ; - -- The new type env is already available to stuff slurped from - -- interface files, via TcEnv.updateGlobalTypeEnv - -- It's important that this includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for boot_dfuns, - -- which may be mentioned in imported unfoldings + -- The new type env is already available to stuff slurped from + -- interface files, via TcEnv.updateGlobalTypeEnv + -- It's important that this includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for boot_dfuns, + -- which may be mentioned in imported unfoldings - -- Don't need to rename the Haddock documentation, - -- it's not parsed by GHC anymore. - tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; + -- Don't need to rename the Haddock documentation, + -- it's not parsed by GHC anymore. + tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ; - -- Report unused names - reportUnusedNames export_ies tcg_env ; + -- Report unused names + reportUnusedNames export_ies tcg_env ; -- add extra source files to tcg_dependent_files addDependentFiles src_files ; -- Dump output and return - tcDump tcg_env ; - return tcg_env + tcDump tcg_env ; + return tcg_env }}}} @@ -229,94 +222,94 @@ implicitPreludeWarn %************************************************************************ -%* * - Import declarations -%* * +%* * + Import declarations +%* * %************************************************************************ \begin{code} -tcRnImports :: HscEnv -> Module +tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; - - ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - -- Make sure we record the dependencies from the DynFlags in the EPS or we - -- end up hitting the sanity check in LoadIface.loadInterface that - -- checks for unknown home-package modules being loaded. We put - -- these dependencies on the left so their (non-source) imports - -- take precedence over the (possibly-source) imports on the right. - -- We don't add them to any other field (e.g. the imp_dep_mods of - -- imports) because we don't want to load their instances etc. - ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] - `plusUFM` imp_dep_mods imports - - -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- get the instances from this module's hs-boot file - ; want_instances :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName this_mod - ; (home_insts, home_fam_insts) = hptInstances hsc_env + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; + + ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) + -- Make sure we record the dependencies from the DynFlags in the EPS or we + -- end up hitting the sanity check in LoadIface.loadInterface that + -- checks for unknown home-package modules being loaded. We put + -- these dependencies on the left so their (non-source) imports + -- take precedence over the (possibly-source) imports on the right. + -- We don't add them to any other field (e.g. the imp_dep_mods of + -- imports) because we don't want to load their instances etc. + ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] + `plusUFM` imp_dep_mods imports + + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_insts) = hptInstances hsc_env want_instances - } ; + } ; - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_imports = rn_imports, - tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) home_fam_insts, - tcg_hpc = hpc_info - }) $ do { - - ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module and family instance-module - -- interfaces, so that their rules and instance decls will be - -- found. - ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) + tcg_hpc = hpc_info + }) $ do { + + ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) (imp_orphs imports) -- Check type-family consistency - ; traceRn (text "rn1: checking family instance consistency") - ; let { dir_imp_mods = moduleEnvKeys - . imp_mods - $ imports } - ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; + ; traceRn (text "rn1: checking family instance consistency") + ; let { dir_imp_mods = moduleEnvKeys + . imp_mods + $ imports } + ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; - ; getGblEnv } } + ; getGblEnv } } \end{code} %************************************************************************ -%* * - Type-checking external-core modules -%* * +%* * + Type-checking external-core modules +%* * %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv - -> HsExtCore RdrName - -> IO (Messages, Maybe ModGuts) - -- Nothing => some error occurred +tcRnExtCore :: HscEnv + -> HsExtCore RdrName + -> IO (Messages, Maybe ModGuts) + -- Nothing => some error occurred tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) - -- The decls are IfaceDecls; all names are original names + -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; initTc hsc_env ExtCoreFile False this_mod $ do { @@ -326,11 +319,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Bring the type and class decls into scope -- ToDo: check that this doesn't need to extract the val binds. -- It seems that only the type and class decls need to be in scope below because - -- (a) tcTyAndClassDecls doesn't need the val binds, and + -- (a) tcTyAndClassDecls doesn't need the val binds, and -- (b) tcExtCoreBindings doesn't need anything -- (in fact, it might not even need to be in the scope of -- this tcg_env at all) - (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} + (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} (mkFakeGroup ldecls) ; setEnvs tc_envs $ do { @@ -338,35 +331,35 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - -- Dump trace of renaming part + -- Dump trace of renaming part rnDump (ppr rn_decls) ; - -- Typecheck them all together so that - -- any mutually recursive types are done right - -- Just discard the auxiliary bindings; they are generated - -- only for Haskell source code, and should already be in Core + -- Typecheck them all together so that + -- any mutually recursive types are done right + -- Just discard the auxiliary bindings; they are generated + -- only for Haskell source code, and should already be in Core tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; setGblEnv tcg_env $ do { - -- Make the new type env available to stuff slurped from interface files - - -- Now the core bindings + -- Make the new type env available to stuff slurped from interface files + + -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; - -- Wrap up + -- Wrap up let { - bndrs = bindersOfBinds core_binds ; - my_exports = map (Avail . idName) bndrs ; - -- ToDo: export the data types also? + bndrs = bindersOfBinds core_binds ; + my_exports = map (Avail . idName) bndrs ; + -- ToDo: export the data types also? mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, + mg_boot = False, mg_used_names = emptyNameSet, -- ToDo: compute usage mg_used_th = False, mg_dir_imps = emptyModuleEnv, -- ?? - mg_deps = noDependencies, -- ?? + mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_tcs = tcg_tcs tcg_env, mg_insts = tcg_insts tcg_env, @@ -402,43 +395,43 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields %************************************************************************ -%* * - Type-checking the top level of a module -%* * +%* * + Type-checking the top level of a module +%* * %************************************************************************ \begin{code} tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv - -- Returns the variables free in the decls - -- Reason: solely to report unused imports and bindings + -- Returns the variables free in the decls + -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls - = do { -- Do all the declarations - ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + = do { -- Do all the declarations + ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; ; traceTc "Tc8" empty ; - ; setEnvs (tcg_env, tcl_env) $ - do { - - -- Finish simplifying class constraints - -- - -- simplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism restriction - -- and no subsequent decl instantiates its type. - -- - -- We do this after checkMain, so that we use the type info - -- that checkMain adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - new_ev_binds <- {-# SCC "simplifyTop" #-} + ; setEnvs (tcg_env, tcl_env) $ + do { + + -- Finish simplifying class constraints + -- + -- simplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- that checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + new_ev_binds <- {-# SCC "simplifyTop" #-} simplifyTop lie ; traceTc "Tc9" empty ; - failIfErrsM ; -- Don't zonk if there have been errors - -- It's a waste of time; and we may get debug warnings - -- about strangely-typed TyCons! + failIfErrsM ; -- Don't zonk if there have been errors + -- It's a waste of time; and we may get debug warnings + -- about strangely-typed TyCons! -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. @@ -453,76 +446,76 @@ tcRnSrcDecls boot_iface decls tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- {-# SCC "zonkTopDecls" #-} zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; - + let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', + tcg_rules = rules', + tcg_vects = vects', tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env } } -tc_rn_src_decls :: ModDetails - -> [LHsDecl RdrName] +tc_rn_src_decls :: ModDetails + -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) --- Loops around dealing with each top level inter-splice group +-- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds = {-# SCC "tc_rn_src_decls" #-} do { (first_group, group_tail) <- findSplice ds ; - -- If ds is [] we get ([], Nothing) - - -- The extra_deps are needed while renaming type and class declarations + -- If ds is [] we get ([], Nothing) + + -- The extra_deps are needed while renaming type and class declarations -- See Note [Extra dependencies from .hs-boot files] in RnSource - let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ; - -- Deal with decls up to, but not including, the first splice - (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ; - -- rnTopSrcDecls fails if there are any errors - - (tcg_env, tcl_env) <- setGblEnv tcg_env $ - tcTopSrcDecls boot_details rn_decls ; - - -- If there is no splice, we're nearly done - setEnvs (tcg_env, tcl_env) $ - case group_tail of { - Nothing -> do { tcg_env <- checkMain ; -- Check for `main' - return (tcg_env, tcl_env) - } ; + let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ; + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ; + -- rnTopSrcDecls fails if there are any errors + + (tcg_env, tcl_env) <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; + + -- If there is no splice, we're nearly done + setEnvs (tcg_env, tcl_env) $ + case group_tail of { + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' + return (tcg_env, tcl_env) + } ; #ifndef GHCI - -- There shouldn't be a splice - Just (SpliceDecl {}, _) -> do { - failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") + -- There shouldn't be a splice + Just (SpliceDecl {}, _) -> do { + failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else - -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr _, rest_ds) -> do { + -- If there's a splice, we must carry on + Just (SpliceDecl splice_expr _, rest_ds) -> do { - -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; - -- checkNoErrs: don't typecheck if renaming failed - rnDump (ppr rn_splice_expr) ; + -- Rename the splice expression, and get its supporting decls + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed + rnDump (ppr rn_splice_expr) ; - -- Execute the splice - spliced_decls <- tcSpliceDecls rn_splice_expr ; + -- Execute the splice + spliced_decls <- tcSpliceDecls rn_splice_expr ; - -- Glue them on the front of the remaining decls and loop - setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) + -- Glue them on the front of the remaining decls and loop + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ } } } \end{code} %************************************************************************ -%* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -%* * +%* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +%* * %************************************************************************ \begin{code} @@ -530,69 +523,69 @@ tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv tcRnHsBootDecls decls = do { (first_group, group_tail) <- findSplice decls - -- Rename the declarations - ; (tcg_env, HsGroup { - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_derivds = deriv_decls, - hs_fords = for_decls, - hs_defds = def_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_annds = _, - hs_valds = val_binds }) <- rnTopSrcDecls [] first_group + -- Rename the declarations + ; (tcg_env, HsGroup { + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_derivds = deriv_decls, + hs_fords = for_decls, + hs_defds = def_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_annds = _, + hs_valds = val_binds }) <- rnTopSrcDecls [] first_group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { - - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl d _, _) -> badBootDecl "splice" d - Nothing -> return () - ; mapM_ (badBootDecl "foreign") for_decls - ; mapM_ (badBootDecl "default") def_decls - ; mapM_ (badBootDecl "rule") rule_decls - ; mapM_ (badBootDecl "vect") vect_decls - - -- Typecheck type/class decls - ; traceTc "Tc2" empty - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck instance decls - -- Family instance declarations are rejected here - ; traceTc "Tc3" empty - ; (tcg_env, inst_infos, _deriv_binds) + ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { + + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl d _, _) -> badBootDecl "splice" d + Nothing -> return () + ; mapM_ (badBootDecl "foreign") for_decls + ; mapM_ (badBootDecl "default") def_decls + ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls + + -- Typecheck type/class decls + ; traceTc "Tc2 (boot)" empty + ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ do { + + -- Typecheck instance decls + -- Family instance declarations are rejected here + ; traceTc "Tc3" empty + ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 }}} ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: String -> Located decl -> TcM () -badBootDecl what (L loc _) - = addErrAt loc (char 'A' <+> text what +badBootDecl what (L loc _) + = addErrAt loc (char 'A' <+> text what <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file")) \end{code} @@ -607,34 +600,34 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv -- of boot_names is empty. -- -- The bindings we return give bindings for the dfuns defined in the --- hs-boot file, such as $fbEqT = $fEqT +-- hs-boot file, such as $fbEqT = $fEqT checkHiBootIface - tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, - tcg_insts = local_insts, - tcg_type_env = local_type_env, tcg_exports = local_exports }) - (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env, md_exports = boot_exports }) - | isHsBoot hs_src -- Current module is already a hs-boot file! - = return tcg_env + tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, + tcg_insts = local_insts, + tcg_type_env = local_type_env, tcg_exports = local_exports }) + (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, + md_types = boot_type_env, md_exports = boot_exports }) + | isHsBoot hs_src -- Current module is already a hs-boot file! + = return tcg_env | otherwise - = do { traceTc "checkHiBootIface" $ vcat + = do { traceTc "checkHiBootIface" $ vcat [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... - -- Check instance declarations - ; mb_dfun_prs <- mapM check_inst boot_insts + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts ; let dfun_prs = catMaybes mb_dfun_prs boot_dfuns = map fst dfun_prs dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) @@ -643,34 +636,34 @@ checkHiBootIface tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } ; failIfErrsM - ; setGlobalTypeEnv tcg_env' type_env' } - -- Update the global type env *including* the knot-tied one + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one -- so that if the source module reads in an interface unfolding -- mentioning one of the dfuns from the boot module, then it -- can "see" that boot dfun. See Trac #4003 where - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` dfun_names = return () - | isWiredInName name = return () -- No checking for wired-in names. In particular, - -- 'error' is handled by a rather gross hack - -- (see comments in GHC.Err.hs-boot) + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) - -- Check that the actual module exports the same thing + -- Check that the actual module exports the same thing | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) + = addErrAt (nameSrcSpan (head missing_names)) (missingBootThing (head missing_names) "exported by") - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) | isNothing mb_boot_thing = return () - -- Check that the actual module also defines the thing, and - -- then compare the definitions + -- Check that the actual module also defines the thing, and + -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name, Just boot_thing <- mb_boot_thing = when (not (checkBootDecl boot_thing real_thing)) $ addErrAt (nameSrcSpan (getName boot_thing)) - (let boot_decl = tyThingToIfaceDecl + (let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) real_decl = tyThingToIfaceDecl real_thing in bootMisMatch real_thing boot_decl real_decl) @@ -678,33 +671,33 @@ checkHiBootIface | otherwise = addErrTc (missingBootThing name "defined in") where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + dfun_names = map getName boot_insts local_export_env :: NameEnv AvailInfo local_export_env = availsToNameEnv local_exports - check_inst :: Instance -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent real dfun + check_inst :: ClsInst -> TcM (Maybe (Id, Id)) + -- Returns a pair of the boot dfun in terms of the equivalent real dfun check_inst boot_inst - = case [dfun | inst <- local_insts, - let dfun = instanceDFunId inst, - idType dfun `eqType` boot_inst_ty ] of - [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) + = case [dfun | inst <- local_insts, + let dfun = instanceDFunId inst, + idType dfun `eqType` boot_inst_ty ] of + [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) , text "boot_inst" <+> ppr boot_inst , text "boot_inst_ty" <+> ppr boot_inst_ty - ]) + ]) ; addErrTc (instMisMatch boot_inst); return Nothing } - (dfun:_) -> return (Just (local_boot_dfun, dfun)) - where - boot_dfun = instanceDFunId boot_inst - boot_inst_ty = idType boot_dfun - local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty + (dfun:_) -> return (Just (local_boot_dfun, dfun)) + where + boot_dfun = instanceDFunId boot_inst + boot_inst_ty = idType boot_dfun + local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty -- This has to compare the TyThing from the .hi-boot file to the TyThing @@ -717,7 +710,7 @@ checkHiBootIface checkBootDecl :: TyThing -> TyThing -> Bool checkBootDecl (AnId id1) (AnId id2) - = ASSERT(id1 == id2) + = ASSERT(id1 == id2) (idType id1 `eqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) @@ -732,14 +725,14 @@ checkBootDecl _ _ = False -- probably shouldn't happen checkBootTyCon :: TyCon -> TyCon -> Bool checkBootTyCon tc1 tc2 | not (eqKind (tyConKind tc1) (tyConKind tc2)) - = False -- First off, check the kind + = False -- First off, check the kind | Just c1 <- tyConClass_maybe tc1 , Just c2 <- tyConClass_maybe tc2 - = let - (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = let + (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) = classExtraBigSig c1 - (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) = classExtraBigSig c2 env0 = mkRnEnv2 emptyInScopeSet @@ -766,7 +759,7 @@ checkBootTyCon tc1 tc2 eqTypeX env ty1 ty2 where env = rnBndrs2 env0 tvs1 tvs2 - eqFD (as1,bs1) (as2,bs2) = + eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) @@ -779,7 +772,7 @@ checkBootTyCon tc1 tc2 || -- Above tests for an "abstract" class eqListBy (eqPredX env) sc_theta1 sc_theta2 && eqListBy eqSig op_stuff1 op_stuff2 && - eqListBy eqAT ats1 ats2) + eqListBy eqAT ats1 ats2) | isSynTyCon tc1 && isSynTyCon tc2 = ASSERT(tc1 == tc2) @@ -806,11 +799,11 @@ checkBootTyCon tc1 tc2 tyConExtName tc1 == tyConExtName tc2 | otherwise = False - where + where env0 = mkRnEnv2 emptyInScopeSet - eqAlgRhs (AbstractTyCon dis1) rhs2 - | dis1 = isDistinctAlgRhs rhs2 --Check compatibility + eqAlgRhs (AbstractTyCon dis1) rhs2 + | dis1 = isDistinctAlgRhs rhs2 --Check compatibility | otherwise = True eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = @@ -829,16 +822,16 @@ checkBootTyCon tc1 tc2 ---------------- missingBootThing :: Name -> String -> SDoc missingBootThing name what - = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") - <+> text what <+> ptext (sLit "the module") + = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") + <+> text what <+> ptext (sLit "the module") bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc bootMisMatch thing boot_decl real_decl = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), - ptext (sLit "Main module:") <+> ppr real_decl, - ptext (sLit "Boot file: ") <+> ppr boot_decl] + ptext (sLit "Main module:") <+> ppr real_decl, + ptext (sLit "Boot file: ") <+> ppr boot_decl] -instMisMatch :: Instance -> SDoc +instMisMatch :: ClsInst -> SDoc instMisMatch inst = hang (ppr inst) 2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself")) @@ -846,9 +839,9 @@ instMisMatch inst %************************************************************************ -%* * - Type-checking the top level of a module -%* * +%* * + Type-checking the top level of a module +%* * %************************************************************************ tcRnGroup takes a bunch of top-level source-code declarations, and @@ -869,70 +862,70 @@ rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls extra_deps group = do { -- Rename the source decls traceTc "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ; traceTc "rn13" empty ; -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; - -- Dump trace of renaming part - rnDump (ppr rn_decls) ; + -- Dump trace of renaming part + rnDump (ppr rn_decls) ; - return (tcg_env', rn_decls) + return (tcg_env', rn_decls) } ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_details - (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, +tcTopSrcDecls boot_details + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_vects = vect_decls, - hs_valds = val_binds }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2" empty ; - - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; - setGblEnv tcg_env $ do { - - -- Source-language instances, including derivings, - -- and import the supporting declarations + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_vects = vect_decls, + hs_valds = val_binds }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + setGblEnv tcg_env $ do { + + -- Source-language instances, including derivings, + -- and import the supporting declarations traceTc "Tc3" empty ; - (tcg_env, inst_infos, deriv_binds) + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls; - setGblEnv tcg_env $ do { + setGblEnv tcg_env $ do { - -- Foreign import declarations next. + -- Foreign import declarations next. traceTc "Tc4" empty ; - (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ do { + (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { - -- Default declarations + -- Default declarations traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; + default_tys <- tcDefaults default_decls ; + updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs <- discardWarnings (tcTopBinds deriv_binds) ; setEnvs tc_envs $ do { - -- Value declarations next + -- Value declarations next traceTc "Tc5" empty ; - tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; - setEnvs tc_envs $ do { -- Environment doesn't change now + tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds; + setEnvs tc_envs $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; @@ -952,13 +945,13 @@ tcTopSrcDecls boot_details -- Wrap up traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds + let { all_binds = inst_binds `unionBags` + foe_binds - ; sig_names = mkNameSet (collectHsValBinders val_binds) + ; sig_names = mkNameSet (collectHsValBinders val_binds) `minusNameSet` getTypeSigNames val_binds - -- Extend the GblEnv with the (as yet un-zonked) + -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names @@ -973,18 +966,18 @@ tcTopSrcDecls boot_details %************************************************************************ -%* * - Checking for 'main' -%* * +%* * + Checking for 'main' +%* * %************************************************************************ \begin{code} checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. -checkMain +checkMain = do { tcg_env <- getGblEnv ; - dflags <- getDOpts ; - check_main dflags tcg_env + dflags <- getDynFlags ; + check_main dflags tcg_env } check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv @@ -994,59 +987,59 @@ check_main dflags tcg_env return tcg_env | otherwise - = do { mb_main <- lookupGlobalOccRn_maybe main_fn - -- Check that 'main' is in scope - -- It might be imported from another module! - ; case mb_main of { - Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) - ; complain_no_main - ; return tcg_env } ; - Just main_name -> do - - { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) - ; let loc = srcLocSpan (getSrcLoc main_name) - ; ioTyCon <- tcLookupTyCon ioTyConName + = do { mb_main <- lookupGlobalOccRn_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn) + ; complain_no_main + ; return tcg_env } ; + Just main_name -> do + + { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn) + ; let loc = srcLocSpan (getSrcLoc main_name) + ; ioTyCon <- tcLookupTyCon ioTyConName ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; main_expr - <- addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedLocalId root_main_name - (mkTyConApp ioTyCon [res_ty]) - ; co = mkWpTyApps [res_ty] - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name, + ; main_expr + <- addErrCtxt mainCtxt $ + tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty]) + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedLocalId root_main_name + (mkTyConApp ioTyCon [res_ty]) + ; co = mkWpTyApps [res_ty] + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name, tcg_binds = tcg_binds tcg_env - `snocBag` main_bind, - tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - }) + `snocBag` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + }) }}} where - mod = tcg_mod tcg_env + mod = tcg_mod tcg_env main_mod = mainModIs dflags main_fn = getMainFun dflags complain_no_main | ghcLink dflags == LinkInMemory = return () - | otherwise = failWithTc noMainMsg - -- In interactive mode, don't worry about the absence of 'main' - -- In other modes, fail altogether, so that we don't go on - -- and complain a second time when processing the export list. + | otherwise = failWithTc noMainMsg + -- In interactive mode, don't worry about the absence of 'main' + -- In other modes, fail altogether, so that we don't go on + -- and complain a second time when processing the export list. mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn noMainMsg = ptext (sLit "The") <+> pp_main_fn - <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) + <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn ppMainFn :: RdrName -> SDoc @@ -1055,7 +1048,7 @@ ppMainFn main_fn = ptext (sLit "function") <+> quotes (ppr main_fn) | otherwise = ptext (sLit "main function") <+> quotes (ppr main_fn) - + -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is getMainFun :: DynFlags -> RdrName @@ -1065,7 +1058,7 @@ getMainFun dflags = case (mainFunIs dflags) of checkMainExported :: TcGblEnv -> TcM () checkMainExported tcg_env = do - dflags <- getDOpts + dflags <- getDynFlags case tcg_main tcg_env of Nothing -> return () -- not the main module Just main_name -> do @@ -1081,7 +1074,7 @@ The function that the RTS invokes is always :Main.main, which we call root_main_id. (Because GHC allows the user to have a module not called Main as the main module, we can't rely on the main function being called "Main.main". That's why root_main_id has a fixed module -":Main".) +":Main".) This is unusual: it's a LocalId whose Name has a Module from another module. Tiresomely, we must filter it out again in MkIface, les we @@ -1089,16 +1082,16 @@ get two defns for 'main' in the interface file! %********************************************************* -%* * - GHCi stuff -%* * +%* * + GHCi stuff +%* * %********************************************************* \begin{code} setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a -setInteractiveContext hsc_env icxt thing_inside - = let -- Initialise the tcg_inst_env with instances from all home modules. - -- This mimics the more selective call to hptInstances in tcRnModule. +setInteractiveContext hsc_env icxt thing_inside + = let -- Initialise the tcg_inst_env with instances from all home modules. + -- This mimics the more selective call to hptInstances in tcRnImports (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) (ic_insts, ic_finsts) = ic_instances icxt @@ -1150,9 +1143,11 @@ setInteractiveContext hsc_env icxt thing_inside (map getOccName visible_tmp_ids) -- Note [delete shadowed tcg_rdr_env entries] , tcg_type_env = type_env + , tcg_insts = ic_insts , tcg_inst_env = extendInstEnvList (extendInstEnvList (tcg_inst_env env) ic_insts) home_insts + , tcg_fam_insts = ic_finsts , tcg_fam_inst_env = extendFamInstEnvList (extendFamInstEnvList (tcg_fam_inst_env env) ic_finsts) @@ -1165,40 +1160,26 @@ setInteractiveContext hsc_env icxt thing_inside tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids] thing_inside -\end{code} - -\begin{code} #ifdef GHCI -tcRnStmt :: HscEnv - -> InteractiveContext - -> LStmt RdrName - -> IO (Messages, Maybe ([Id], LHsExpr Id)) - -- The returned [Id] is the list of new Ids bound by - -- this statement. It can be used to extend the - -- InteractiveContext via extendInteractiveContext. - -- - -- The returned TypecheckedHsExpr is of type IO [ () ], - -- a list of the bound values, coerced to (). - +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound +-- values, coerced to (). +tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName + -> IO (Messages, Maybe ([Id], LHsExpr Id)) tcRnStmt hsc_env ictxt rdr_stmt - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> - return ((), emptyFVs) ; - traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; - failIfErrsM ; - rnDump (ppr rn_stmt) ; - -- The real work is done here - (bound_ids, tc_expr) <- mkPlan rn_stmt ; + (bound_ids, tc_expr) <- tcUserStmt rdr_stmt ; zonked_expr <- zonkTopLExpr tc_expr ; zonked_ids <- zonkTopBndrs bound_ids ; - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc "tcs 1" empty ; @@ -1210,37 +1191,37 @@ tcRnStmt hsc_env ictxt rdr_stmt they are inaccessible but might, I suppose, cause a space leak if we leave them there. However, with Template Haskell they aren't necessarily inaccessible. Consider this GHCi session - Prelude> let f n = n * 2 :: Int - Prelude> fName <- runQ [| f |] - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) - 14 - Prelude> let f n = n * 3 :: Int - Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) In the last line we use 'fName', which resolves to the *first* 'f' in scope. If we delete it from the type env, GHCi crashes because it doesn't expect that. - + Hence this code is commented out -------------------------------------------------- -} - dumpOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; + dumpOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; return (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), - nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) \end{code} Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently - a) GlobalIds + a) GlobalIds b) with an Internal Name (not External) - c) and a tidied type + c) and a tidied type (a) They must be GlobalIds (not LocalIds) otherwise when we come to compile an expression using these ids later, the byte code @@ -1248,163 +1229,189 @@ The Ids bound by previous Stmts in GHCi are currently global. (b) They retain their Internal names becuase we don't have a suitable - Module to name them with. We could revisit this choice. + Module to name them with. We could revisit this choice. - (c) Their types are tidied. This is important, because :info may ask + (c) Their types are tidied. This is important, because :info may ask to look at them, and :info expects the things it looks up to have tidy types - -------------------------------------------------------------------------- - Typechecking Stmts in GHCi + Typechecking Stmts in GHCi Here is the grand plan, implemented in tcUserStmt - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] - expr (of non-IO type, - result not showable) ==> error + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + expr (of non-IO type, + result not showable) ==> error \begin{code} ---------------------------- + +-- | A plan is an attempt to lift some code into the IO monad. type PlanResult = ([Id], LHsExpr Id) type Plan = TcM PlanResult -runPlans :: [Plan] -> TcM PlanResult --- Try the plans in order. If one fails (by raising an exn), try the next. +-- | Try the plans in order. If one fails (by raising an exn), try the next. -- If one succeeds, take it. +runPlans :: [Plan] -> TcM PlanResult runPlans [] = panic "runPlans" runPlans [p] = p runPlans (p:ps) = tryTcLIE_ (runPlans ps) p --------------------- -mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt - = do { uniq <- newUnique -- is treated very specially +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environemnt'. +-- +-- By 'lift' and 'environment we mean that the code is changed to execute +-- properly in an IO monad. See Note [Interactively-bound Ids in GHCi] above +-- for more details. We do this lifting by trying different ways ('plans') of +-- lifting the code into the IO monad and type checking each plan until one +-- succeeds. +tcUserStmt :: LStmt RdrName -> TcM PlanResult + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (ExprStmt expr _ _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + -- Don't try to typecheck if the renamer fails! + ; uniq <- newUnique ; let fresh_it = itName uniq loc - the_bind = L loc $ mkTopFunBind (L loc fresh_it) matches - matches = [mkMatch [] expr emptyLocalBinds] - let_stmt = L loc $ LetStmt $ HsValBinds $ + matches = [mkMatch [] rn_expr emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + + -- [let it = expr] + let_stmt = L loc $ LetStmt $ HsValBinds $ ValBindsOut [(NonRecursive,unitBag the_bind)] [] - bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) expr - (HsVar bindIOName) noSyntaxExpr - print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - -- The plans are: - -- [it <- e; print it] but not if it::() - -- [it <- e] - -- [let it = e; print it] - ; runPlans [ -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM - ; return stuff }, - - -- Plan B; a naked bind statment - tcGhciStmts [bind_stmt], - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } - ]} - -mkPlan stmt@(L loc (BindStmt {})) - | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt - = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) noSyntaxExpr placeHolderType - - ; print_bind_result <- doptM Opt_PrintBindResult - ; let print_plan = do - { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - - -- The plans are: - -- [stmt; print v] but not if v::() - -- [stmt] - ; runPlans ((if print_bind_result then [print_plan] else []) ++ - [tcGhciStmts [stmt]]) - } - -mkPlan stmt - = tcGhciStmts [stmt] - ---------------------------- + -- [it <- e] + bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) rn_expr + (HsVar bindIOName) noSyntaxExpr + -- [; print it] + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + + -- The plans are: + -- A. [it <- e; print it] but not if it::() + -- B. [it <- e] + -- C. [let it = e; print it] + ; runPlans [ -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; when (isUnitTy it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statment + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } + ]} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], _), fvs) <- checkNoErrs $ + rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; + -- Don't try to typecheck if the renamer fails! + ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump (ppr rn_stmt) ; + + ; opt_pr_flag <- doptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders rn_stmt -- One binder + = [mk_print_result_plan rn_stmt v] + | otherwise = [] + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; runPlans (print_result_plan ++ [tcGhciStmts [rn_stmt]]) } + where + mk_print_result_plan rn_stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [rn_stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) noSyntaxExpr placeHolderType + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [()]'. tcGhciStmts :: [LStmt Name] -> TcM PlanResult tcGhciStmts stmts = do { ioTyCon <- tcLookupTyCon ioTyConName ; - ret_id <- tcLookupId returnIOName ; -- return @ IO - let { - ret_ty = mkListTy unitTy ; - io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; - names = collectLStmtsBinders stmts ; - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureConstraints $ - tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; + ret_id <- tcLookupId returnIOName ; -- return @ IO + let { + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + tc_io_stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; + names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + traceTc "TcRnDriver.tcGhciStmts: done" empty ; let { -- mk_return builds the expression - -- returnIO @ [()] [coerce () x, .., coerce () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; - mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) ; - stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] } ; - return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt stmts io_ret_ty)) + return (ids, mkHsDictLet (EvBinds const_binds) $ + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} - tcRnExpr just finds the type of an expression \begin{code} tcRnExpr :: HscEnv -> InteractiveContext - -> LHsExpr RdrName - -> IO (Messages, Maybe Type) + -> LHsExpr RdrName + -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { @@ -1412,12 +1419,12 @@ tcRnExpr hsc_env ictxt rdr_expr (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; - -- Now typecheck the expression; - -- it might have a rank-2 type (e.g. :t runST) + -- Now typecheck the expression; + -- it might have a rank-2 type (e.g. :t runST) uniq <- newUnique ; let { fresh_it = itName uniq (getLoc rdr_expr) } ; - ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ {-# SCC "simplifyInfer" #-} simplifyInfer True {- Free vars are closed -} False {- No MR for now -} @@ -1431,10 +1438,10 @@ tcRnExpr hsc_env ictxt rdr_expr -------------------------- tcRnImportDecls :: HscEnv - -> [LImportDecl RdrName] - -> IO (Messages, Maybe GlobalRdrEnv) + -> [LImportDecl RdrName] + -> IO (Messages, Maybe GlobalRdrEnv) tcRnImportDecls hsc_env import_decls - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls ; return (tcg_rdr_env gbl_env) } \end{code} @@ -1443,28 +1450,28 @@ tcRnType just finds the kind of a type \begin{code} tcRnType :: HscEnv - -> InteractiveContext - -> Bool -- Normalise the returned type - -> LHsType RdrName - -> IO (Messages, Maybe (Type, Kind)) + -> InteractiveContext + -> Bool -- Normalise the returned type + -> LHsType RdrName + -> IO (Messages, Maybe (Type, Kind)) tcRnType hsc_env ictxt normalise rdr_type - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { rn_type <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; - -- Now kind-check the type - -- It can have any rank or kind + -- Now kind-check the type + -- It can have any rank or kind ty <- tcHsSigType GhciCtxt rn_type ; - ty' <- if normalise - then do { fam_envs <- tcGetFamInstEnvs + ty' <- if normalise + then do { fam_envs <- tcGetFamInstEnvs ; return (snd (normaliseType fam_envs ty)) } - -- normaliseType returns a coercion - -- which we discard + -- normaliseType returns a coercion + -- which we discard else return ty ; - + return (ty', typeKind ty) } @@ -1473,16 +1480,16 @@ tcRnType hsc_env ictxt normalise rdr_type tcRnDeclsi exists to allow class, data, and other declarations in GHCi. \begin{code} -tcRnDeclsi :: HscEnv +tcRnDeclsi :: HscEnv -> InteractiveContext - -> [LHsDecl RdrName] - -> IO (Messages, Maybe TcGblEnv) + -> [LHsDecl RdrName] + -> IO (Messages, Maybe TcGblEnv) tcRnDeclsi hsc_env ictxt local_decls = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do - - ((tcg_env, tclcl_env), lie) <- + + ((tcg_env, tclcl_env), lie) <- captureConstraints $ tc_rn_src_decls emptyModDetails local_decls setEnvs (tcg_env, tclcl_env) $ do @@ -1498,16 +1505,16 @@ tcRnDeclsi hsc_env ictxt local_decls = tcg_fords = fords } = tcg_env all_ev_binds = cur_ev_binds `unionBags` new_ev_binds - (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords - + let --global_ids = map globaliseAndTidyId bind_ids final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids tcg_env' = tcg_env { tcg_binds = binds', tcg_ev_binds = ev_binds', tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_vects = vects', + tcg_rules = rules', + tcg_vects = vects', tcg_fords = fords' } tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env @@ -1520,9 +1527,9 @@ tcRnDeclsi hsc_env ictxt local_decls = %************************************************************************ -%* * - More GHCi stuff, to do with browsing and getting info -%* * +%* * + More GHCi stuff, to do with browsing and getting info +%* * %************************************************************************ \begin{code} @@ -1539,7 +1546,7 @@ getModuleInterface hsc_env mod tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext hsc_env (hsc_IC hsc_env) $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ lookup_rdr_name rdr_name lookup_rdr_name :: RdrName -> TcM [Name] @@ -1554,7 +1561,7 @@ lookup_rdr_name rdr_name = do traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]) -- The successful lookups will be (Just name) - let (warns_s, good_names) = unzip [ (msgs, name) + let (warns_s, good_names) = unzip [ (msgs, name) | (msgs, Just name) <- results] errs_s = [msgs | (msgs, Nothing) <- results] @@ -1564,9 +1571,9 @@ lookup_rdr_name rdr_name = do -- No lookup succeeded, so -- pick the first error message and report it -- ToDo: If one of the errors is "could be Foo.X or Baz.X", - -- while the other is "X is not in scope", - -- we definitely want the former; but we might pick the latter - else mapM_ addMessages warns_s + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter + else mapM_ addMessages warns_s -- Add deprecation warnings return good_names @@ -1579,7 +1586,7 @@ tcRnLookupName hsc_env name tcRnLookupName' name -- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. +-- as well as the global environment, which is what tcLookup does. -- But we also want a TyThing, so we have to convert: tcRnLookupName' :: Name -> TcRn TyThing @@ -1592,14 +1599,14 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO (Messages, Maybe (TyThing, Fixity, [Instance])) + -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst])) -- Used to implement :info in GHCi -- -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1607,15 +1614,15 @@ tcRnGetInfo hsc_env name tcRnGetInfo' :: HscEnv -> Name - -> TcRn (TyThing, Fixity, [Instance]) + -> TcRn (TyThing, Fixity, [ClsInst]) tcRnGetInfo' hsc_env name = let ictxt = hsc_IC hsc_env in setInteractiveContext hsc_env ictxt $ do - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) loadUnqualIfaces hsc_env ictxt thing <- tcRnLookupName' name @@ -1623,7 +1630,7 @@ tcRnGetInfo' hsc_env name ispecs <- lookupInsts thing return (thing, fixity, ispecs) -lookupInsts :: TyThing -> TcM [Instance] +lookupInsts :: TyThing -> TcM [ClsInst] lookupInsts (ATyCon tc) | Just cls <- tyConClass_maybe tc = do { inst_envs <- tcGetInstEnvs @@ -1631,22 +1638,22 @@ lookupInsts (ATyCon tc) | otherwise = do { (pkg_ie, home_ie) <- tcGetInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - ; return [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , let dfun = instanceDFunId ispec - , relevant dfun ] } + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + ; return [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , let dfun = instanceDFunId ispec + , relevant dfun ] } where relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df) - tc_name = tyConName tc + tc_name = tyConName tc lookupInsts _ = return [] loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () -- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for +-- This is so that we can accurately report the instances for -- something loadUnqualIfaces hsc_env ictxt = initIfaceTcRn $ do @@ -1656,18 +1663,18 @@ loadUnqualIfaces hsc_env ictxt unqual_mods = filter ((/= this_pkg) . modulePackageId) [ nameModule name - | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), - let name = gre_name gre, + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), + let name = gre_name gre, not (isInternalName name), - isTcOcc (nameOccName name), -- Types and classes only - unQualOK gre ] -- In scope unqualified + isTcOcc (nameOccName name), -- Types and classes only + unQualOK gre ] -- In scope unqualified doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified") \end{code} %************************************************************************ -%* * - Degugging output -%* * +%* * + Degugging output +%* * %************************************************************************ \begin{code} @@ -1677,104 +1684,104 @@ rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } tcDump :: TcGblEnv -> TcRn () tcDump env - = do { dflags <- getDOpts ; + = do { dflags <- getDynFlags ; - -- Dump short output if -ddump-types or -ddump-tc - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn short_dump) ; + -- Dump short output if -ddump-types or -ddump-tc + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn short_dump) ; - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } where short_dump = pprTcGblEnv env full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords tcCoreDump :: ModGuts -> TcM () tcCoreDump mod_guts - = do { dflags <- getDOpts ; - when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn (pprModGuts mod_guts)) ; + = do { dflags <- getDynFlags ; + when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) + (dumpTcRn (pprModGuts mod_guts)) ; - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) } where full_dump = pprCoreBindings (mg_binds mod_guts) -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, tcg_rules = rules, tcg_vects = vects, tcg_imports = imports }) = vcat [ ppr_types insts type_env - , ppr_tycons fam_insts type_env + , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts , vcat (map ppr rules) , vcat (map ppr vects) - , ptext (sLit "Dependent modules:") <+> + , ptext (sLit "Dependent modules:") <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) - , ptext (sLit "Dependent packages:") <+> - ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] - where -- The two uses of sortBy are just to reduce unnecessary - -- wobbling in testsuite output + , ptext (sLit "Dependent packages:") <+> + ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + where -- The two uses of sortBy are just to reduce unnecessary + -- wobbling in testsuite output cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) - = (mod_name1 `stableModuleNameCmp` mod_name2) - `thenCmp` - (is_boot1 `compare` is_boot2) + = (mod_name1 `stableModuleNameCmp` mod_name2) + `thenCmp` + (is_boot1 `compare` is_boot2) pprModGuts :: ModGuts -> SDoc pprModGuts (ModGuts { mg_tcs = tcs , mg_rules = rules }) = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)), - ppr_rules rules ] + ppr_rules rules ] -ppr_types :: [Instance] -> TypeEnv -> SDoc +ppr_types :: [ClsInst] -> TypeEnv -> SDoc ppr_types insts type_env = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) where dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && - isExternalName (idName id) && - not (id `elem` dfun_ids) - -- isLocalId ignores data constructors, records selectors etc. - -- The isExternalName ignores local dictionary and method bindings - -- that the type checker has invented. Top-level user-defined things - -- have External names. + | otherwise = isLocalId id && + isExternalName (idName id) && + not (id `elem` dfun_ids) + -- isLocalId ignores data constructors, records selectors etc. + -- The isExternalName ignores local dictionary and method bindings + -- that the type checker has invented. Top-level user-defined things + -- have External names. ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env = vcat [ text "TYPE CONSTRUCTORS" , nest 2 (ppr_tydecls tycons) - , text "COERCION AXIOMS" + , text "COERCION AXIOMS" , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] where - fi_tycons = map famInstTyCon fam_insts + fi_tycons = famInstsRepTyCons fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] want_tycon tycon | opt_PprStyle_Debug = True - | otherwise = not (isImplicitTyCon tycon) && - isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) -ppr_insts :: [Instance] -> SDoc +ppr_insts :: [ClsInst] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) ppr_fam_insts :: [FamInst] -> SDoc ppr_fam_insts [] = empty -ppr_fam_insts fam_insts = +ppr_fam_insts fam_insts = text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) ppr_sigs :: [Var] -> SDoc ppr_sigs ids - -- Print type signatures; sort by OccName + -- Print type signatures; sort by OccName = vcat (map ppr_sig (sortLe le_sig ids)) where le_sig id1 id2 = getOccName id1 <= getOccName id2 @@ -1782,7 +1789,7 @@ ppr_sigs ids ppr_tydecls :: [TyCon] -> SDoc ppr_tydecls tycons - -- Print type constructor info; sort by OccName + -- Print type constructor info; sort by OccName = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 @@ -1791,6 +1798,6 @@ ppr_tydecls tycons ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), - nest 2 (pprRules rs), - ptext (sLit "#-}")] + nest 2 (pprRules rs), + ptext (sLit "#-}")] \end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 381d5355d1..351a3e25d0 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -23,6 +23,8 @@ import Module import RdrName import Name import Type +import Kind ( isSuperKind ) + import TcType import InstEnv import FamInstEnv @@ -252,17 +254,14 @@ setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = Command-line flags \begin{code} -getDOpts :: TcRnIf gbl lcl DynFlags -getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } - xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool -xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } +xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) } doptM :: DynFlag -> TcRnIf gbl lcl Bool -doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } +doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) } woptM :: WarningFlag -> TcRnIf gbl lcl Bool -woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) } +woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) } setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setXOptM flag = updEnv (\ env@(Env { env_top = top }) -> @@ -448,14 +447,14 @@ traceOptTcRn :: DynFlag -> SDoc -> TcRn () traceOptTcRn flag doc = ifDOptM flag $ do { loc <- getSrcSpanM ; let real_doc - | opt_PprStyle_Debug = mkLocMessage loc doc + | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc | otherwise = doc -- The full location is -- usually way too much ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv - ; dflags <- getDOpts + ; dflags <- getDynFlags ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } debugDumpTcRn :: SDoc -> TcRn () @@ -561,13 +560,13 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: Message -> TcRn () -- Ignores the context stack +addErr :: MsgDoc -> TcRn () -- Ignores the context stack addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: Message -> TcRn a +failWith :: MsgDoc -> TcRn a failWith msg = addErr msg >> failM -addErrAt :: SrcSpan -> Message -> TcRn () +addErrAt :: SrcSpan -> MsgDoc -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter @@ -576,22 +575,16 @@ addErrAt loc msg = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo tidy_env ctxt ; addLongErrAt loc msg err_info } -addErrs :: [(SrcSpan,Message)] -> TcRn () +addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty - -addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty - -checkErr :: Bool -> Message -> TcRn () +checkErr :: Bool -> MsgDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -warnIf :: Bool -> Message -> TcRn () +warnIf :: Bool -> MsgDoc -> TcRn () warnIf True msg = addWarn msg warnIf False _ = return () @@ -626,32 +619,34 @@ discardWarnings thing_inside %************************************************************************ \begin{code} -addReport :: Message -> Message -> TcRn () -addReport msg extra_info = do { traceTc "addr" msg; loc <- getSrcSpanM; addReportAt loc msg extra_info } +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt loc msg extra + = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDynFlags ; + return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } -addReportAt :: SrcSpan -> Message -> Message -> TcRn () -addReportAt loc msg extra_info +addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError + +reportErrors :: [ErrMsg] -> TcM () +reportErrors = mapM_ reportError + +reportError :: ErrMsg -> TcRn () +reportError err = do { errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) - msg extra_info } ; (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns `snocBag` warn, errs) } + writeTcRef errs_var (warns, errs `snocBag` err) } -addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () -addLongErrAt loc msg extra - = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ; - errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; +reportWarning :: ErrMsg -> TcRn () +reportWarning warn + = do { errs_var <- getErrsVar ; (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns, errs `snocBag` err) } + writeTcRef errs_var (warns `snocBag` warn, errs) } dumpDerivingInfo :: SDoc -> TcM () dumpDerivingInfo doc - = do { dflags <- getDOpts + = do { dflags <- getDynFlags ; when (dopt Opt_D_dump_deriv dflags) $ do { rdr_env <- getGlobalRdrEnv ; let unqual = mkPrintUnqualified dflags rdr_env @@ -721,7 +716,7 @@ tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) -- there might be warnings tryTcErrs thing = do { (msgs, res) <- tryTc thing - ; dflags <- getDOpts + ; dflags <- getDynFlags ; let errs_found = errorsFound dflags msgs ; return (msgs, case res of Nothing -> Nothing @@ -771,13 +766,13 @@ checkNoErrs main } ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out main +-- ifErrsM bale_out normal -- does 'bale_out' if there are errors in errors collection --- otherwise does 'main' +-- otherwise does 'normal' ifErrsM bale_out normal = do { errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; - dflags <- getDOpts ; + dflags <- getDynFlags ; if errorsFound dflags msgs then bale_out else @@ -802,13 +797,13 @@ getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -addErrCtxt :: Message -> TcM a -> TcM a +addErrCtxt :: MsgDoc -> TcM a -> TcM a addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) -addLandmarkErrCtxt :: Message -> TcM a -> TcM a +addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts) -- Helper function for the above @@ -840,32 +835,40 @@ setCtLoc (CtLoc _ src_loc ctxt) thing_inside tidy up the message; we then use it to tidy the context messages \begin{code} -addErrTc :: Message -> TcM () +addErrTc :: MsgDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrsTc :: [Message] -> TcM () +addErrsTc :: [MsgDoc] -> TcM () addErrsTc err_msgs = mapM_ addErrTc err_msgs -addErrTcM :: (TidyEnv, Message) -> TcM () +addErrTcM :: (TidyEnv, MsgDoc) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; add_err_tcm tidy_env err_msg loc ctxt } + +-- Return the error message, instead of reporting it straight away +mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg +mkErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + err_info <- mkErrInfo tidy_env ctxt ; + mkLongErrAt loc err_msg err_info } \end{code} The failWith functions add an error message and cause failure \begin{code} -failWithTc :: Message -> TcM a -- Add an error message and fail +failWithTc :: MsgDoc -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true +checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err \end{code} @@ -873,20 +876,39 @@ checkTc False err = failWithTc err Warnings have no 'M' variant, nor failure \begin{code} -addWarnTc :: Message -> TcM () +warnTc :: Bool -> MsgDoc -> TcM () +warnTc warn_if_true warn_msg + | warn_if_true = addWarnTc warn_msg + | otherwise = return () + +addWarnTc :: MsgDoc -> TcM () addWarnTc msg = do { env0 <- tcInitTidyEnv ; addWarnTcM (env0, msg) } -addWarnTcM :: (TidyEnv, Message) -> TcM () +addWarnTcM :: (TidyEnv, MsgDoc) -> TcM () addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; - addReport (ptext (sLit "Warning:") <+> msg) err_info } + add_warn msg err_info } -warnTc :: Bool -> Message -> TcM () -warnTc warn_if_true warn_msg - | warn_if_true = addWarnTc warn_msg - | otherwise = return () +addWarn :: MsgDoc -> TcRn () +addWarn msg = add_warn msg empty + +addWarnAt :: SrcSpan -> MsgDoc -> TcRn () +addWarnAt loc msg = add_warn_at loc msg empty + +add_warn :: MsgDoc -> MsgDoc -> TcRn () +add_warn msg extra_info + = do { loc <- getSrcSpanM + ; add_warn_at loc msg extra_info } + +add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at loc msg extra_info + = do { rdr_env <- getGlobalRdrEnv ; + dflags <- getDynFlags ; + let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + msg extra_info } ; + reportWarning warn } \end{code} ----------------------------------- @@ -917,7 +939,7 @@ tcInitTidyEnv Other helper functions \begin{code} -add_err_tcm :: TidyEnv -> Message -> SrcSpan +add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan -> [ErrCtxt] -> TcM () add_err_tcm tidy_env err_msg loc ctxt @@ -927,8 +949,8 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts - | opt_PprStyle_Debug -- In -dppr-debug style the output - = return empty -- just becomes too voluminous +-- | opt_PprStyle_Debug -- In -dppr-debug style the output +-- = return empty -- just becomes too voluminous | otherwise = go 0 env ctxts where @@ -974,6 +996,11 @@ addTcEvBind (EvBindsVar ev_ref _) var t = do { bnds <- readTcRef ev_ref ; writeTcRef ev_ref (extendEvBinds bnds var t) } +getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind) +getTcEvBinds (EvBindsVar ev_ref _) + = do { bnds <- readTcRef ev_ref + ; return (evBindMapBinds bnds) } + chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn = do { env <- getGblEnv @@ -994,24 +1021,15 @@ emitConstraints ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`andWC` ct) } -emitFlat :: WantedEvVar -> TcM () +emitFlat :: Ct -> TcM () emitFlat ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addFlats` unitBag ct) } -emitFlats :: Bag WantedEvVar -> TcM () -emitFlats ct +emitFlats :: Cts -> TcM () +emitFlats cts = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addFlats` ct) } - -emitWantedCts :: Cts -> TcM () --- Precondition: all wanted -emitWantedCts = mapBagM_ emit_wanted_ct - where emit_wanted_ct ct - | v <- cc_id ct - , Wanted loc <- cc_flavor ct - = emitFlat (EvVarX v loc) - | otherwise = panic "emitWantedCts: can't emit non-wanted!" + updTcRef lie_var (`addFlats` cts) } emitImplication :: Implication -> TcM () emitImplication ct @@ -1042,8 +1060,13 @@ captureUntouchables thing_inside ; return (res, TouchableRange low_meta high_meta) } isUntouchable :: TcTyVar -> TcM Bool -isUntouchable tv = do { env <- getLclEnv - ; return (varUnique tv < tcl_untch env) } +isUntouchable tv + -- Kind variables are always touchable + | isSuperKind (tyVarKind tv) + = return False + | otherwise + = do { env <- getLclEnv + ; return (varUnique tv < tcl_untch env) } getLclTypeEnv :: TcM TcTypeEnv getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } @@ -1189,7 +1212,7 @@ getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } -------------------- -failIfM :: Message -> IfL a +failIfM :: MsgDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldnt happen". -- We use IfL here so that we can get context info out of the local env diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ab26fa1e09..8ff3ce3f76 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -54,29 +54,31 @@ module TcRnTypes( Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, singleCt, extendCts, isEmptyCts, isCTyEqCan, isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, - isCIrredEvCan, isCNonCanonical, - SubGoalDepth, ctPred, + isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, + isGivenCt_maybe, isGivenOrSolvedCt, + ctWantedLoc, + SubGoalDepth, mkNonCanonical, ctPred, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, addFlats, addImplics, mkFlatWC, - EvVarX(..), mkEvVarX, evVarOf, evVarX, evVarOfPred, - WantedEvVar, - Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, + WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, + pushErrCtxtSameOrigin, SkolemInfo(..), - CtFlavor(..), pprFlavorArising, isWanted, - isGivenOrSolved, isGiven_maybe, isSolved, - isDerived, + CtFlavor(..), pprFlavorArising, + mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, + isWanted, isGivenOrSolved, isGiven_maybe, isSolved, + isDerived, getWantedLoc, canSolve, canRewrite, + combineCtLoc, -- Pretty printing - pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs, - pprEvVars, pprEvVarWithType, pprWantedEvVarWithLoc, + pprEvVarTheta, pprWantedsWithLocs, + pprEvVars, pprEvVarWithType, pprArising, pprArisingAt, -- Misc other types @@ -114,6 +116,7 @@ import UniqSupply import Unique import BasicTypes import Bag +import DynFlags import Outputable import ListSetOps import FastString @@ -185,6 +188,9 @@ data Env gbl lcl env_lcl :: lcl -- Nested stuff; changes as we go into } +instance ContainsDynFlags (Env gbl lcl) where + extractDynFlags env = hsc_dflags (env_top env) + -- TcGblEnv describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer @@ -304,7 +310,7 @@ data TcGblEnv tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_tcs :: [TyCon], -- ...TyCons and Classes - tcg_insts :: [Instance], -- ...Instances + tcg_insts :: [ClsInst], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl Id], -- ...Rules tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports @@ -650,7 +656,7 @@ Note that: \begin{code} -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message)) +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction @@ -902,6 +908,8 @@ data Ct \end{code} \begin{code} +mkNonCanonical :: EvVar -> CtFlavor -> Ct +mkNonCanonical ev flav = CNonCanonical { cc_id = ev, cc_flavor = flav, cc_depth = 0} ctPred :: Ct -> PredType ctPred (CNonCanonical { cc_id = v }) = evVarPred v @@ -917,6 +925,57 @@ ctPred (CIrredEvCan { cc_ty = xi }) = xi \end{code} +%************************************************************************ +%* * + CtFlavor + The "flavor" of a canonical constraint +%* * +%************************************************************************ + +\begin{code} +ctWantedLoc :: Ct -> WantedLoc +-- Only works for Wanted/Derived +ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct ) + getWantedLoc (cc_flavor ct) + +isWantedCt :: Ct -> Bool +isWantedCt ct = isWanted (cc_flavor ct) + +isDerivedCt :: Ct -> Bool +isDerivedCt ct = isDerived (cc_flavor ct) + +isGivenCt_maybe :: Ct -> Maybe GivenKind +isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) + +isGivenOrSolvedCt :: Ct -> Bool +isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) + +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan (CFunEqCan {}) = False +isCTyEqCan _ = False + +isCDictCan_Maybe :: Ct -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCIPCan_Maybe :: Ct -> Maybe (IPName Name) +isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm +isCIPCan_Maybe _ = Nothing + +isCIrredEvCan :: Ct -> Bool +isCIrredEvCan (CIrredEvCan {}) = True +isCIrredEvCan _ = False + +isCFunEqCan_Maybe :: Ct -> Maybe TyCon +isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc +isCFunEqCan_Maybe _ = Nothing + +isCNonCanonical :: Ct -> Bool +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False +\end{code} + \begin{code} instance Outputable Ct where ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct)) @@ -950,31 +1009,6 @@ emptyCts = emptyBag isEmptyCts :: Cts -> Bool isEmptyCts = isEmptyBag - -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan (CFunEqCan {}) = False -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCIPCan_Maybe :: Ct -> Maybe (IPName Name) -isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm -isCIPCan_Maybe _ = Nothing - -isCIrredEvCan :: Ct -> Bool -isCIrredEvCan (CIrredEvCan {}) = True -isCIrredEvCan _ = False - -isCFunEqCan_Maybe :: Ct -> Maybe TyCon -isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc -isCFunEqCan_Maybe _ = Nothing - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False \end{code} %************************************************************************ @@ -991,7 +1025,7 @@ v%************************************************************************ \begin{code} data WantedConstraints - = WC { wc_flat :: Cts -- Unsolved constraints, all wanted + = WC { wc_flat :: Cts -- Unsolved constraints, all wanted , wc_impl :: Bag Implication , wc_insol :: Cts -- Insoluble constraints, can be -- wanted, given, or derived @@ -1021,12 +1055,9 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) , wc_impl = i1 `unionBags` i2 , wc_insol = n1 `unionBags` n2 } -addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints -addFlats wc wevs +addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints +addFlats wc cts = wc { wc_flat = wc_flat wc `unionBags` cts } - where cts = mapBag mk_noncan wevs - mk_noncan (EvVarX v wl) - = CNonCanonical { cc_id = v, cc_flavor = Wanted wl, cc_depth = 0} addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } @@ -1095,7 +1126,7 @@ data Implication -- However, we don't zonk ic_env when zonking the Implication -- Instead we do that when generating a skolem-escape error message - ic_skols :: TcTyVarSet, -- Introduced skolems + ic_skols :: [TcTyVar], -- Introduced skolems -- See Note [Skolems in an implication] ic_given :: [EvVar], -- Given evidence variables @@ -1162,38 +1193,11 @@ will be able to report a more informative error: %************************************************************************ %* * - EvVarX, WantedEvVar, FlavoredEvVar + Pretty printing %* * %************************************************************************ \begin{code} -data EvVarX a = EvVarX EvVar a - -- An evidence variable with accompanying info - -type WantedEvVar = EvVarX WantedLoc -- The location where it arose - - -instance Outputable (EvVarX a) where - ppr (EvVarX ev _) = pprEvVarWithType ev - -- If you want to see the associated info, - -- use a more specific printing function - -mkEvVarX :: EvVar -> a -> EvVarX a -mkEvVarX = EvVarX - -evVarOf :: EvVarX a -> EvVar -evVarOf (EvVarX ev _) = ev - -evVarX :: EvVarX a -> a -evVarX (EvVarX _ a) = a - -evVarOfPred :: EvVarX a -> PredType -evVarOfPred wev = evVarPred (evVarOf wev) - -\end{code} - - -\begin{code} pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) @@ -1208,11 +1212,6 @@ pprWantedsWithLocs wcs = vcat [ pprBag ppr (wc_flat wcs) , pprBag ppr (wc_impl wcs) , pprBag ppr (wc_insol wcs) ] - -pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc -pprWantedEvVarWithLoc (EvVarX v loc) = hang (pprEvVarWithType v) - 2 (pprArisingAt loc) -pprWantedEvVar (EvVarX v _) = pprEvVarWithType v \end{code} %************************************************************************ @@ -1241,6 +1240,11 @@ instance Outputable CtFlavor where ppr (Wanted {}) = ptext (sLit "[W]") ppr (Derived {}) = ptext (sLit "[D]") +getWantedLoc :: CtFlavor -> WantedLoc +getWantedLoc (Wanted wl) = wl +getWantedLoc (Derived wl) = wl +getWantedLoc flav@(Given {}) = pprPanic "getWantedLoc" (ppr flav) + pprFlavorArising :: CtFlavor -> SDoc pprFlavorArising (Derived wl) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl @@ -1265,6 +1269,52 @@ isGiven_maybe _ = Nothing isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True isDerived _ = False + +canSolve :: CtFlavor -> CtFlavor -> Bool +-- canSolve ctid1 ctid2 +-- The constraint ctid1 can be used to solve ctid2 +-- "to solve" means a reaction where the active parts of the two constraints match. +-- active(F xis ~ xi) = F xis +-- active(tv ~ xi) = tv +-- active(D xis) = D xis +-- active(IP nm ty) = nm +-- +-- NB: either (a `canSolve` b) or (b `canSolve` a) must hold +----------------------------------------- +canSolve (Given {}) _ = True +canSolve (Wanted {}) (Derived {}) = True +canSolve (Wanted {}) (Wanted {}) = True +canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given +canSolve _ _ = False -- (There is no *evidence* for a derived.) + +canRewrite :: CtFlavor -> CtFlavor -> Bool +-- canRewrite ctid1 ctid2 +-- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 +canRewrite = canSolve + +combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc +-- Precondition: At least one of them should be wanted +combineCtLoc (Wanted loc) _ = loc +combineCtLoc _ (Wanted loc) = loc +combineCtLoc (Derived loc ) _ = loc +combineCtLoc _ (Derived loc ) = loc +combineCtLoc _ _ = panic "combineCtLoc: both given" + +mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor +-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) +mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) +mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) +mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl + +mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor +mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl + +mkWantedFlavor :: CtFlavor -> CtFlavor +mkWantedFlavor (Wanted loc) = Wanted loc +mkWantedFlavor (Derived loc) = Wanted loc +mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) \end{code} %************************************************************************ @@ -1296,6 +1346,10 @@ setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs) +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc orig -> CtLoc orig +-- Just add information w/o updating the origin! +pushErrCtxtSameOrigin err (CtLoc o s errs) = CtLoc o s (err:errs) + pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message -- We've done special processing for TypeEq and FunDep origins @@ -1350,7 +1404,8 @@ data SkolemInfo | BracketSkol -- Template Haskell bracket | UnifyForAllSkol -- We are unifying two for-all types - TcType + [TcTyVar] -- The instantiated skolem variables + TcType -- The instantiated type *inside* the forall | UnkSkol -- Unhelpful info (until I improve it) @@ -1380,7 +1435,7 @@ pprSkolInfo (PatSkol dc mc) = sep [ ptext (sLit "a pattern with constructor") pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol ty) = ptext (sLit "the type") <+> ppr ty +pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAllTys tvs ty) -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 2c38b2ffde..660007d7c5 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -30,7 +30,7 @@ module TcSMonad ( canRewrite, canSolve, combineCtLoc, mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, - getWantedLoc, + ctWantedLoc, TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality traceFireTcS, bumpStepCountTcS, doWithInert, @@ -60,7 +60,7 @@ module TcSMonad ( -- Inerts InertSet(..), - getInertEqs, liftInertEqsTy, getCtCoercion, + getInertEqs, getCtCoercion, emptyInert, getTcSInerts, updInertSet, extractUnsolved, extractUnsolvedTcS, modifyInertTcS, updInertSetTcS, partitionCCanMap, partitionEqMap, @@ -72,7 +72,7 @@ module TcSMonad ( instDFunConstraints, newFlexiTcSTy, instFlexiTcS, - compatKind, compatKindTcS, isSubKindTcS, unifyKindTcS, + compatKind, mkKindErrorCtxtTcS, TcsUntouchables, isTouchableMetaTyVar, @@ -104,7 +104,7 @@ import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcGetDefaultTys ) -import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt ) +import {-# SOURCE #-} qualified TcUnify as TcM ( mkKindErrorCtxt ) import Kind import TcType import DynFlags @@ -113,7 +113,6 @@ import Type import TcEvidence import Class import TyCon -import TypeRep import Name import Var @@ -145,23 +144,12 @@ import TrieMap compatKind :: Kind -> Kind -> Bool compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 -compatKindTcS :: Kind -> Kind -> TcS Bool --- Because kind unification happens during constraint solving, we have --- to make sure that two kinds are zonked before we compare them. -compatKindTcS k1 k2 = wrapTcS (TcM.compatKindTcM k1 k2) - -isSubKindTcS :: Kind -> Kind -> TcS Bool -isSubKindTcS k1 k2 = wrapTcS (TcM.isSubKindTcM k1 k2) - -unifyKindTcS :: Type -> Type -- Context - -> Kind -> Kind -- Corresponding kinds - -> TcS Bool -unifyKindTcS ty1 ty2 ki1 ki2 - = wrapTcS $ TcM.addErrCtxtM ctxt $ do - (_errs, mb_r) <- TcM.tryTc (TcM.unifyKindEq ki1 ki2) - return (maybe False (const True) mb_r) - where - ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2 +mkKindErrorCtxtTcS :: Type -> Kind + -> Type -> Kind + -> ErrCtxt +mkKindErrorCtxtTcS ty1 ki1 ty2 ki2 + = (False,TcM.mkKindErrorCtxt ty1 ty2 ki1 ki2) + \end{code} %************************************************************************ @@ -612,82 +600,6 @@ extractRelevantInerts wi \end{code} - - -%************************************************************************ -%* * - CtFlavor - The "flavor" of a canonical constraint -%* * -%************************************************************************ - -\begin{code} -getWantedLoc :: Ct -> WantedLoc -getWantedLoc ct - = ASSERT (isWanted (cc_flavor ct)) - case cc_flavor ct of - Wanted wl -> wl - _ -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty - -isWantedCt :: Ct -> Bool -isWantedCt ct = isWanted (cc_flavor ct) -isDerivedCt :: Ct -> Bool -isDerivedCt ct = isDerived (cc_flavor ct) - -isGivenCt_maybe :: Ct -> Maybe GivenKind -isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) - -isGivenOrSolvedCt :: Ct -> Bool -isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) - - -canSolve :: CtFlavor -> CtFlavor -> Bool --- canSolve ctid1 ctid2 --- The constraint ctid1 can be used to solve ctid2 --- "to solve" means a reaction where the active parts of the two constraints match. --- active(F xis ~ xi) = F xis --- active(tv ~ xi) = tv --- active(D xis) = D xis --- active(IP nm ty) = nm --- --- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ------------------------------------------ -canSolve (Given {}) _ = True -canSolve (Wanted {}) (Derived {}) = True -canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given -canSolve _ _ = False -- (There is no *evidence* for a derived.) - -canRewrite :: CtFlavor -> CtFlavor -> Bool --- canRewrite ctid1 ctid2 --- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 -canRewrite = canSolve - -combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc --- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc ) _ = loc -combineCtLoc _ (Derived loc ) = loc -combineCtLoc _ _ = panic "combineCtLoc: both given" - -mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor --- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) -mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl - -mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl - -mkWantedFlavor :: CtFlavor -> CtFlavor -mkWantedFlavor (Wanted loc) = Wanted loc -mkWantedFlavor (Derived loc) = Wanted loc -mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) -\end{code} - %************************************************************************ %* * %* The TcS solver monad * @@ -854,7 +766,7 @@ runTcS context untouch is wl tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_cache_var <- TcM.newTcRef $ EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM } - ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds + ; ev_binds_var <- TcM.newTcEvBinds ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef is @@ -883,8 +795,8 @@ runTcS context untouch is wl tcs <+> int count <+> ppr context) } -- And return - ; ev_binds <- TcM.readTcRef evb_ref - ; return (res, evBindMapBinds ev_binds) } + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty @@ -1010,8 +922,8 @@ emitFrozenError fl ev depth inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) } -getDynFlags :: TcS DynFlags -getDynFlags = wrapTcS TcM.getDOpts +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags getTcSContext :: TcS SimplContext getTcSContext = TcS (return . tcs_context) @@ -1209,7 +1121,8 @@ isTouchableMetaTyVar tv isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool isTouchableMetaTyVar_InRange (untch,untch_tcs) tv - = case tcTyVarDetails tv of + = ASSERT2 ( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs) -- See Note [Touchable meta type variables] MetaTv {} -> inTouchableRange untch tv @@ -1481,7 +1394,7 @@ matchClass clas tys } } -matchFam :: TyCon -> [Type] -> TcS (Maybe (TyCon, [Type])) +matchFam :: TyCon -> [Type] -> TcS (Maybe (FamInst, [Type])) matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args \end{code} @@ -1506,67 +1419,5 @@ getCtCoercion ct -- Instead we use the most accurate type, given by ctPred c where maybe_given = isGiven_maybe (cc_flavor ct) --- See Note [LiftInertEqs] -liftInertEqsTy :: (TyVarEnv (Ct, TcCoercion),InScopeSet) - -> CtFlavor - -> PredType -> TcCoercion -liftInertEqsTy (subst,inscope) fl pty - = ty_cts_subst subst inscope fl pty - - -ty_cts_subst :: TyVarEnv (Ct, TcCoercion) - -> InScopeSet -> CtFlavor -> Type -> TcCoercion -ty_cts_subst subst inscope fl ty - = go ty - where - go ty = go' ty - - go' (TyVarTy tv) = tyvar_cts_subst tv `orElse` mkTcReflCo (TyVarTy tv) - go' (AppTy ty1 ty2) = mkTcAppCo (go ty1) (go ty2) - go' (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys) - - go' (ForAllTy v ty) = mkTcForAllCo v' $! co - where - (subst',inscope',v') = upd_tyvar_bndr subst inscope v - co = ty_cts_subst subst' inscope' fl ty - - go' (FunTy ty1 ty2) = mkTcFunCo (go ty1) (go ty2) - - - tyvar_cts_subst tv - | Just (ct,co) <- lookupVarEnv subst tv, cc_flavor ct `canRewrite` fl - = Just co -- Warn: use cached, not cc_id directly, because of alpha-renamings! - | otherwise = Nothing - - upd_tyvar_bndr subst inscope v - = (new_subst, (inscope `extendInScopeSet` new_v), new_v) - where new_subst - | no_change = delVarEnv subst v - -- Otherwise we have to extend the environment with /something/. - -- But we do not want to monadically create a new EvVar. So, we - -- create an 'unused_ct' but we cache reflexivity as the - -- associated coercion. - | otherwise = extendVarEnv subst v (unused_ct, mkTcReflCo (TyVarTy new_v)) - - no_change = new_v == v - new_v = uniqAway inscope v - - unused_ct = CTyEqCan { cc_id = unused_evvar - , cc_flavor = fl -- canRewrite is reflexive. - , cc_tyvar = v - , cc_rhs = mkTyVarTy new_v - , cc_depth = unused_depth } - unused_depth = panic "ty_cts_subst: This depth should not be accessed!" - unused_evvar = panic "ty_cts_subst: This var is just an alpha-renaming!" -\end{code} - -Note [LiftInertEqsTy] -~~~~~~~~~~~~~~~~~~~~~~~ -The function liftInertEqPred behaves almost like liftCoSubst (in -Coercion), but accepts a map TyVarEnv (Ct,Coercion) instead of a -LiftCoSubst. This data structure is more convenient to use since we -must apply the inert substitution /only/ if the inert equality -`canRewrite` the work item. There's admittedly some duplication of -functionality but it would be more tedious to cache and maintain -different flavors of LiftCoSubst structures in the inerts. +\end{code}
\ No newline at end of file diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index a36be651b4..39a0ab7985 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -40,6 +40,7 @@ import Control.Monad ( when ) import Outputable import FastString import TrieMap +import DynFlags \end{code} @@ -110,9 +111,9 @@ simplifyDeriv orig pred tvs theta ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) - ; (residual_wanted, _binds) - <- solveWanteds (SimplInfer doc) NoUntouchables $ - mkFlatWC wanted + ; (residual_wanted, _ev_binds1) + <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $ + solveWanteds $ mkFlatWC wanted ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] @@ -121,7 +122,9 @@ simplifyDeriv orig pred tvs theta | otherwise = Right ct where p = ctPred ct - ; reportUnsolved (residual_wanted { wc_flat = bad }) + -- We never want to defer these errors because they are errors in the + -- compiler! Hence the `False` below + ; _ev_binds2 <- reportUnsolved False (residual_wanted { wc_flat = bad }) ; let min_theta = mkMinimalBySCs (bagToList good) ; return (substTheta subst_skol min_theta) } @@ -247,6 +250,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds = do { zonked_wanteds <- zonkWC wanteds ; zonked_taus <- zonkTcTypes (map snd name_taus) ; gbl_tvs <- tcGetGlobalTyVars + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) @@ -274,46 +278,50 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds , ptext (sLit "surely_fref =") <+> ppr surely_free ] - ; emitWantedCts surely_free + ; emitFlats surely_free ; traceTc "sinf" $ vcat [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound , ptext (sLit "surely_free =") <+> ppr surely_free ] -- Step 2 - -- Now simplify the possibly-bound constraints - ; (simpl_results, tc_binds0) - <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables emptyInert emptyWorkList $ - simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) - - ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint - (do { reportUnsolved simpl_results; failM }) + -- Now simplify the possibly-bound constraints + ; let ctxt = SimplInfer (ppr (map fst name_taus)) + ; (simpl_results, tc_binds) + <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ + simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) + + -- Fail fast if there is an insoluble constraint, + -- unless we are deferring errors to runtime + ; when (not runtimeCoercionErrors && insolubleWC simpl_results) $ + do { _ev_binds <- reportUnsolved False simpl_results + ; failM } -- Step 3 -- Split again simplified_perhaps_bound, because some unifications -- may have happened, and emit the free constraints. ; gbl_tvs <- tcGetGlobalTyVars ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs - ; zonked_simples <- zonkCts (wc_flat simpl_results) + ; zonked_flats <- zonkCts (wc_flat simpl_results) ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growWantedEVs gbl_tvs zonked_simples init_tvs - (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_simples + poly_qtvs = growWantedEVs gbl_tvs zonked_flats init_tvs + (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_flats -- Monomorphism restriction mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfCts zonked_simples + constrained_tvs = tyVarsOfCts zonked_flats mr_bites = apply_mr && not (isEmptyBag pbound) (qtvs, (bound, free)) - | mr_bites = (mr_qtvs, (emptyBag, zonked_simples)) + | mr_bites = (mr_qtvs, (emptyBag, zonked_flats)) | otherwise = (poly_qtvs, (pbound, pfree)) - ; emitWantedCts free + ; emitFlats free ; if isEmptyVarSet qtvs && isEmptyBag bound then ASSERT( isEmptyBag (wc_insol simpl_results) ) do { traceTc "} simplifyInfer/no quantification" empty ; emitImplications (wc_impl simpl_results) - ; return ([], [], mr_bites, EvBinds tc_binds0) } + ; return ([], [], mr_bites, EvBinds tc_binds) } else do -- Step 4, zonk quantified variables @@ -331,12 +339,13 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Minimize `bound' and emit an implication ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds ; ev_binds_var <- newTcEvBinds - ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) tc_binds0 + ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) + tc_binds ; lcl_env <- getLclTypeEnv ; gloc <- getCtLoc skol_info ; let implic = Implic { ic_untch = NoUntouchables , ic_env = lcl_env - , ic_skols = mkVarSet qtvs_to_return + , ic_skols = qtvs_to_return , ic_given = minimal_bound_ev_vars , ic_wanted = simpl_results { wc_flat = bound } , ic_insol = False @@ -347,7 +356,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds vcat [ ptext (sLit "implic =") <+> ppr implic -- ic_skols, ic_given give rest of result , ptext (sLit "qtvs =") <+> ppr qtvs_to_return - , ptext (sLit "spb =") <+> ppr zonked_simples + , ptext (sLit "spb =") <+> ppr zonked_flats , ptext (sLit "bound =") <+> ppr bound ] @@ -405,7 +414,7 @@ approximateImplications impls float_implic skols imp = (unitBag (imp { ic_wanted = wanted' }), floats) where - (wanted', floats) = float_wc (skols `unionVarSet` ic_skols imp) (ic_wanted imp) + (wanted', floats) = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) float_wc skols wc@(WC { wc_flat = flat, wc_impl = implic }) = (wc { wc_flat = flat', wc_impl = implic' }, floats1 `unionBags` floats2) @@ -444,7 +453,7 @@ growImplics gbl_tvs implics tvs = foldrBag grow_implic tvs implics where grow_implic implic tvs - = grow tvs `minusVarSet` ic_skols implic + = grow tvs `delVarSetList` ic_skols implic where grow = growWC gbl_tvs (ic_wanted implic) . growPreds gbl_tvs evVarPred (listToBag (ic_given implic)) @@ -568,7 +577,7 @@ Consider f :: (forall a. Eq a => a->a) -> Bool -> ... {-# RULES "foo" forall (v::forall b. Eq b => b->b). f b True = ... - #=} + #-} Here we *must* solve the wanted (Eq a) from the given (Eq a) resulting from skolemising the agument type of g. So we revert to SimplCheck when going under an implication. @@ -590,7 +599,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- solveWanteds (SimplRuleLhs name) untch zonked_lhs + <- runTcS (SimplRuleLhs name) untch emptyInert emptyWorkList $ + solveWanteds zonked_lhs ; traceTc "simplifyRule" $ vcat [ text "zonked_lhs" <+> ppr zonked_lhs @@ -609,7 +619,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted ; ev_binds_var <- newTcEvBinds ; emitImplication $ Implic { ic_untch = untch , ic_env = emptyNameEnv - , ic_skols = mkVarSet tv_bndrs + , ic_skols = tv_bndrs , ic_given = lhs_dicts , ic_wanted = lhs_results { wc_flat = eqs } , ic_insol = insolubleWC lhs_results @@ -638,7 +648,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted , wc_impl = unitBag $ Implic { ic_untch = NoUntouchables , ic_env = emptyNameEnv - , ic_skols = mkVarSet tv_bndrs + , ic_skols = tv_bndrs , ic_given = lhs_dicts , ic_wanted = rhs_wanted , ic_insol = insolubleWC rhs_wanted @@ -680,29 +690,66 @@ simplifyCheck ctxt wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, ev_binds) <- - solveWanteds ctxt NoUntouchables wanteds + ; (unsolved, eb1) + <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ + solveWanteds wanteds + + ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved - ; traceTc "simplifyCheck }" $ - ptext (sLit "unsolved =") <+> ppr unsolved + -- See Note [Deferring coercion errors to runtime] + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors + ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved + + ; return (eb1 `unionBags` eb2) } +\end{code} - ; reportUnsolved unsolved +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ; return ev_binds } +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: ----------------- -solveWanteds :: SimplContext - -> Untouchables - -> WantedConstraints - -> TcM (WantedConstraints, Bag EvBind) + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fwarn-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. + +\begin{code} +solveWanteds :: WantedConstraints -> TcS WantedConstraints -- Returns: residual constraints, plus evidence bindings -- NB: When we are called from TcM there are no inerts to pass down to TcS -solveWanteds ctxt untch wanted - = do { (wc_out, ev_binds) <- runTcS ctxt untch emptyInert emptyWorkList $ - solve_wanteds wanted +solveWanteds wanted + = do { wc_out <- solve_wanteds wanted ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } -- Discard Derived - ; return (wc_ret, ev_binds) } + ; return wc_ret } solve_wanteds :: WantedConstraints -> TcS WantedConstraints -- NB: wc_flats may be wanted *or* derived now @@ -874,7 +921,7 @@ solveImplication tcs_untouchables -- and we are back to the original inerts -floatEqualities :: TcTyVarSet -> [EvVar] -> Cts -> (Cts, Cts) +floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts) -- Post: The returned FlavoredEvVar's are only Wanted or Derived -- and come from the input wanted ev vars or deriveds floatEqualities skols can_given wantders @@ -882,11 +929,12 @@ floatEqualities skols can_given wantders -- Note [Float Equalities out of Implications] | otherwise = partitionBag is_floatable wantders - where is_floatable :: Ct -> Bool + where skol_set = mkVarSet skols + is_floatable :: Ct -> Bool is_floatable ct | ct_predty <- ctPred ct , isEqPred ct_predty - = skols `disjointVarSet` tvs_under_fsks ct_predty + = skol_set `disjointVarSet` tvs_under_fsks ct_predty is_floatable _ct = False tvs_under_fsks :: Type -> TyVarSet diff --git a/compiler/typecheck/TcSimplify.lhs-old b/compiler/typecheck/TcSimplify.lhs-old deleted file mode 100644 index 274c14d70b..0000000000 --- a/compiler/typecheck/TcSimplify.lhs-old +++ /dev/null @@ -1,3297 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -TcSimplify - -\begin{code} -module TcSimplify ( - tcSimplifyInfer, tcSimplifyInferCheck, - tcSimplifyCheck, tcSimplifyRestricted, - tcSimplifyRuleLhs, tcSimplifyIPs, - tcSimplifySuperClasses, - tcSimplifyTop, tcSimplifyInteractive, - tcSimplifyBracket, tcSimplifyCheckPat, - - tcSimplifyDeriv, tcSimplifyDefault, - bindInstsOfLocalFuns, - - misMatchMsg - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TcUnify( unifyType ) -import HsSyn - -import TcRnMonad -import TcHsSyn ( hsLPatType ) -import Inst -import TcEnv -import InstEnv -import TcType -import TcMType -import TcIface -import TcTyFuns -import DsUtils -- Big-tuple functions -import Var -import Id -import Name -import NameSet -import Class -import FunDeps -import PrelInfo -import PrelNames -import TysWiredIn -import ErrUtils -import BasicTypes -import VarSet -import VarEnv -import FiniteMap -import Bag -import Outputable -import ListSetOps -import Util -import SrcLoc -import DynFlags -import FastString - -import Control.Monad -import Data.List -\end{code} - - -%************************************************************************ -%* * -\subsection{NOTES} -%* * -%************************************************************************ - - -------------------------------------- - Notes on functional dependencies (a bug) - -------------------------------------- - -Consider this: - - class C a b | a -> b - class D a b | a -> b - - instance D a b => C a b -- Undecidable - -- (Not sure if it's crucial to this eg) - f :: C a b => a -> Bool - f _ = True - - g :: C a b => a -> Bool - g = f - -Here f typechecks, but g does not!! Reason: before doing improvement, -we reduce the (C a b1) constraint from the call of f to (D a b1). - -Here is a more complicated example: - -@ - > class Foo a b | a->b - > - > class Bar a b | a->b - > - > data Obj = Obj - > - > instance Bar Obj Obj - > - > instance (Bar a b) => Foo a b - > - > foo:: (Foo a b) => a -> String - > foo _ = "works" - > - > runFoo:: (forall a b. (Foo a b) => a -> w) -> w - > runFoo f = f Obj - - *Test> runFoo foo - - <interactive>:1: - Could not deduce (Bar a b) from the context (Foo a b) - arising from use of `foo' at <interactive>:1 - Probable fix: - Add (Bar a b) to the expected type of an expression - In the first argument of `runFoo', namely `foo' - In the definition of `it': it = runFoo foo - - Why all of the sudden does GHC need the constraint Bar a b? The - function foo didn't ask for that... -@ - -The trouble is that to type (runFoo foo), GHC has to solve the problem: - - Given constraint Foo a b - Solve constraint Foo a b' - -Notice that b and b' aren't the same. To solve this, just do -improvement and then they are the same. But GHC currently does - simplify constraints - apply improvement - and loop - -That is usually fine, but it isn't here, because it sees that Foo a b is -not the same as Foo a b', and so instead applies the instance decl for -instance Bar a b => Foo a b. And that's where the Bar constraint comes -from. - -The Right Thing is to improve whenever the constraint set changes at -all. Not hard in principle, but it'll take a bit of fiddling to do. - -Note [Choosing which variables to quantify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are about to do a generalisation step. We have in our hand - - G the environment - T the type of the RHS - C the constraints from that RHS - -The game is to figure out - - Q the set of type variables over which to quantify - Ct the constraints we will *not* quantify over - Cq the constraints we will quantify over - -So we're going to infer the type - - forall Q. Cq => T - -and float the constraints Ct further outwards. - -Here are the things that *must* be true: - - (A) Q intersect fv(G) = EMPTY limits how big Q can be - (B) Q superset fv(Cq union T) \ oclose(fv(G),C) limits how small Q can be - - (A) says we can't quantify over a variable that's free in the environment. - (B) says we must quantify over all the truly free variables in T, else - we won't get a sufficiently general type. - -We do not *need* to quantify over any variable that is fixed by the -free vars of the environment G. - - BETWEEN THESE TWO BOUNDS, ANY Q WILL DO! - -Example: class H x y | x->y where ... - - fv(G) = {a} C = {H a b, H c d} - T = c -> b - - (A) Q intersect {a} is empty - (B) Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d} - - So Q can be {c,d}, {b,c,d} - -In particular, it's perfectly OK to quantify over more type variables -than strictly necessary; there is no need to quantify over 'b', since -it is determined by 'a' which is free in the envt, but it's perfectly -OK to do so. However we must not quantify over 'a' itself. - -Other things being equal, however, we'd like to quantify over as few -variables as possible: smaller types, fewer type applications, more -constraints can get into Ct instead of Cq. Here's a good way to -choose Q: - - Q = grow( fv(T), C ) \ oclose( fv(G), C ) - -That is, quantify over all variable that that MIGHT be fixed by the -call site (which influences T), but which aren't DEFINITELY fixed by -G. This choice definitely quantifies over enough type variables, -albeit perhaps too many. - -Why grow( fv(T), C ) rather than fv(T)? Consider - - class H x y | x->y where ... - - T = c->c - C = (H c d) - - If we used fv(T) = {c} we'd get the type - - forall c. H c d => c -> b - - And then if the fn was called at several different c's, each of - which fixed d differently, we'd get a unification error, because - d isn't quantified. Solution: quantify d. So we must quantify - everything that might be influenced by c. - -Why not oclose( fv(T), C )? Because we might not be able to see -all the functional dependencies yet: - - class H x y | x->y where ... - instance H x y => Eq (T x y) where ... - - T = c->c - C = (Eq (T c d)) - -Now oclose(fv(T),C) = {c}, because the functional dependency isn't -apparent yet, and that's wrong. We must really quantify over d too. - -There really isn't any point in quantifying over any more than -grow( fv(T), C ), because the call sites can't possibly influence -any other type variables. - - - -------------------------------------- - Note [Ambiguity] -------------------------------------- - -It's very hard to be certain when a type is ambiguous. Consider - - class K x - class H x y | x -> y - instance H x y => K (x,y) - -Is this type ambiguous? - forall a b. (K (a,b), Eq b) => a -> a - -Looks like it! But if we simplify (K (a,b)) we get (H a b) and -now we see that a fixes b. So we can't tell about ambiguity for sure -without doing a full simplification. And even that isn't possible if -the context has some free vars that may get unified. Urgle! - -Here's another example: is this ambiguous? - forall a b. Eq (T b) => a -> a -Not if there's an insance decl (with no context) - instance Eq (T b) where ... - -You may say of this example that we should use the instance decl right -away, but you can't always do that: - - class J a b where ... - instance J Int b where ... - - f :: forall a b. J a b => a -> a - -(Notice: no functional dependency in J's class decl.) -Here f's type is perfectly fine, provided f is only called at Int. -It's premature to complain when meeting f's signature, or even -when inferring a type for f. - - - -However, we don't *need* to report ambiguity right away. It'll always -show up at the call site.... and eventually at main, which needs special -treatment. Nevertheless, reporting ambiguity promptly is an excellent thing. - -So here's the plan. We WARN about probable ambiguity if - - fv(Cq) is not a subset of oclose(fv(T) union fv(G), C) - -(all tested before quantification). -That is, all the type variables in Cq must be fixed by the the variables -in the environment, or by the variables in the type. - -Notice that we union before calling oclose. Here's an example: - - class J a b c | a b -> c - fv(G) = {a} - -Is this ambiguous? - forall b c. (J a b c) => b -> b - -Only if we union {a} from G with {b} from T before using oclose, -do we see that c is fixed. - -It's a bit vague exactly which C we should use for this oclose call. If we -don't fix enough variables we might complain when we shouldn't (see -the above nasty example). Nothing will be perfect. That's why we can -only issue a warning. - - -Can we ever be *certain* about ambiguity? Yes: if there's a constraint - - c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY - -then c is a "bubble"; there's no way it can ever improve, and it's -certainly ambiguous. UNLESS it is a constant (sigh). And what about -the nasty example? - - class K x - class H x y | x -> y - instance H x y => K (x,y) - -Is this type ambiguous? - forall a b. (K (a,b), Eq b) => a -> a - -Urk. The (Eq b) looks "definitely ambiguous" but it isn't. What we are after -is a "bubble" that's a set of constraints - - Cq = Ca union Cq' st fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY - -Hence another idea. To decide Q start with fv(T) and grow it -by transitive closure in Cq (no functional dependencies involved). -Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok. -The definitely-ambiguous can then float out, and get smashed at top level -(which squashes out the constants, like Eq (T a) above) - - - -------------------------------------- - Notes on principal types - -------------------------------------- - - class C a where - op :: a -> a - - f x = let g y = op (y::Int) in True - -Here the principal type of f is (forall a. a->a) -but we'll produce the non-principal type - f :: forall a. C Int => a -> a - - - -------------------------------------- - The need for forall's in constraints - -------------------------------------- - -[Exchange on Haskell Cafe 5/6 Dec 2000] - - class C t where op :: t -> Bool - instance C [t] where op x = True - - p y = (let f :: c -> Bool; f x = op (y >> return x) in f, y ++ []) - q y = (y ++ [], let f :: c -> Bool; f x = op (y >> return x) in f) - -The definitions of p and q differ only in the order of the components in -the pair on their right-hand sides. And yet: - - ghc and "Typing Haskell in Haskell" reject p, but accept q; - Hugs rejects q, but accepts p; - hbc rejects both p and q; - nhc98 ... (Malcolm, can you fill in the blank for us!). - -The type signature for f forces context reduction to take place, and -the results of this depend on whether or not the type of y is known, -which in turn depends on which component of the pair the type checker -analyzes first. - -Solution: if y::m a, float out the constraints - Monad m, forall c. C (m c) -When m is later unified with [], we can solve both constraints. - - - -------------------------------------- - Notes on implicit parameters - -------------------------------------- - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, becuase then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you *must* quantify -over implicit parameters. See the predicate isFreeWhenInferring. - - -Note [Implicit parameters and ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only a *class* predicate can give rise to ambiguity -An *implicit parameter* cannot. For example: - foo :: (?x :: [a]) => Int - foo = length ?x -is fine. The call site will suppply a particular 'x' - -Furthermore, the type variables fixed by an implicit parameter -propagate to the others. E.g. - foo :: (Show a, ?x::[a]) => Int - foo = show (?x++?x) -The type of foo looks ambiguous. But it isn't, because at a call site -we might have - let ?x = 5::Int in foo -and all is well. In effect, implicit parameters are, well, parameters, -so we can take their type variables into account as part of the -"tau-tvs" stuff. This is done in the function 'FunDeps.grow'. - - -Question 2: type signatures -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -BUT WATCH OUT: When you supply a type signature, we can't force you -to quantify over implicit parameters. For example: - - (?x + 1) :: Int - -This is perfectly reasonable. We do not want to insist on - - (?x + 1) :: (?x::Int => Int) - -That would be silly. Here, the definition site *is* the occurrence site, -so the above strictures don't apply. Hence the difference between -tcSimplifyCheck (which *does* allow implicit paramters to be inherited) -and tcSimplifyCheckBind (which does not). - -What about when you supply a type signature for a binding? -Is it legal to give the following explicit, user type -signature to f, thus: - - f :: Int -> Int - f x = (x::Int) + ?y - -At first sight this seems reasonable, but it has the nasty property -that adding a type signature changes the dynamic semantics. -Consider this: - - (let f x = (x::Int) + ?y - in (f 3, f 3 with ?y=5)) with ?y = 6 - - returns (3+6, 3+5) -vs - (let f :: Int -> Int - f x = x + ?y - in (f 3, f 3 with ?y=5)) with ?y = 6 - - returns (3+6, 3+6) - -Indeed, simply inlining f (at the Haskell source level) would change the -dynamic semantics. - -Nevertheless, as Launchbury says (email Oct 01) we can't really give the -semantics for a Haskell program without knowing its typing, so if you -change the typing you may change the semantics. - -To make things consistent in all cases where we are *checking* against -a supplied signature (as opposed to inferring a type), we adopt the -rule: - - a signature does not need to quantify over implicit params. - -[This represents a (rather marginal) change of policy since GHC 5.02, -which *required* an explicit signature to quantify over all implicit -params for the reasons mentioned above.] - -But that raises a new question. Consider - - Given (signature) ?x::Int - Wanted (inferred) ?x::Int, ?y::Bool - -Clearly we want to discharge the ?x and float the ?y out. But -what is the criterion that distinguishes them? Clearly it isn't -what free type variables they have. The Right Thing seems to be -to float a constraint that - neither mentions any of the quantified type variables - nor any of the quantified implicit parameters - -See the predicate isFreeWhenChecking. - - -Question 3: monomorphism -~~~~~~~~~~~~~~~~~~~~~~~~ -There's a nasty corner case when the monomorphism restriction bites: - - z = (x::Int) + ?y - -The argument above suggests that we *must* generalise -over the ?y parameter, to get - z :: (?y::Int) => Int, -but the monomorphism restriction says that we *must not*, giving - z :: Int. -Why does the momomorphism restriction say this? Because if you have - - let z = x + ?y in z+z - -you might not expect the addition to be done twice --- but it will if -we follow the argument of Question 2 and generalise over ?y. - - -Question 4: top level -~~~~~~~~~~~~~~~~~~~~~ -At the top level, monomorhism makes no sense at all. - - module Main where - main = let ?x = 5 in print foo - - foo = woggle 3 - - woggle :: (?x :: Int) => Int -> Int - woggle y = ?x + y - -We definitely don't want (foo :: Int) with a top-level implicit parameter -(?x::Int) becuase there is no way to bind it. - - -Possible choices -~~~~~~~~~~~~~~~~ -(A) Always generalise over implicit parameters - Bindings that fall under the monomorphism restriction can't - be generalised - - Consequences: - * Inlining remains valid - * No unexpected loss of sharing - * But simple bindings like - z = ?y + 1 - will be rejected, unless you add an explicit type signature - (to avoid the monomorphism restriction) - z :: (?y::Int) => Int - z = ?y + 1 - This seems unacceptable - -(B) Monomorphism restriction "wins" - Bindings that fall under the monomorphism restriction can't - be generalised - Always generalise over implicit parameters *except* for bindings - that fall under the monomorphism restriction - - Consequences - * Inlining isn't valid in general - * No unexpected loss of sharing - * Simple bindings like - z = ?y + 1 - accepted (get value of ?y from binding site) - -(C) Always generalise over implicit parameters - Bindings that fall under the monomorphism restriction can't - be generalised, EXCEPT for implicit parameters - Consequences - * Inlining remains valid - * Unexpected loss of sharing (from the extra generalisation) - * Simple bindings like - z = ?y + 1 - accepted (get value of ?y from occurrence sites) - - -Discussion -~~~~~~~~~~ -None of these choices seems very satisfactory. But at least we should -decide which we want to do. - -It's really not clear what is the Right Thing To Do. If you see - - z = (x::Int) + ?y - -would you expect the value of ?y to be got from the *occurrence sites* -of 'z', or from the valuue of ?y at the *definition* of 'z'? In the -case of function definitions, the answer is clearly the former, but -less so in the case of non-fucntion definitions. On the other hand, -if we say that we get the value of ?y from the definition site of 'z', -then inlining 'z' might change the semantics of the program. - -Choice (C) really says "the monomorphism restriction doesn't apply -to implicit parameters". Which is fine, but remember that every -innocent binding 'x = ...' that mentions an implicit parameter in -the RHS becomes a *function* of that parameter, called at each -use of 'x'. Now, the chances are that there are no intervening 'with' -clauses that bind ?y, so a decent compiler should common up all -those function calls. So I think I strongly favour (C). Indeed, -one could make a similar argument for abolishing the monomorphism -restriction altogether. - -BOTTOM LINE: we choose (B) at present. See tcSimplifyRestricted - - - -%************************************************************************ -%* * -\subsection{tcSimplifyInfer} -%* * -%************************************************************************ - -tcSimplify is called when we *inferring* a type. Here's the overall game plan: - - 1. Compute Q = grow( fvs(T), C ) - - 2. Partition C based on Q into Ct and Cq. Notice that ambiguous - predicates will end up in Ct; we deal with them at the top level - - 3. Try improvement, using functional dependencies - - 4. If Step 3 did any unification, repeat from step 1 - (Unification can change the result of 'grow'.) - -Note: we don't reduce dictionaries in step 2. For example, if we have -Eq (a,b), we don't simplify to (Eq a, Eq b). So Q won't be different -after step 2. However note that we may therefore quantify over more -type variables than we absolutely have to. - -For the guts, we need a loop, that alternates context reduction and -improvement with unification. E.g. Suppose we have - - class C x y | x->y where ... - -and tcSimplify is called with: - (C Int a, C Int b) -Then improvement unifies a with b, giving - (C Int a, C Int a) - -If we need to unify anything, we rattle round the whole thing all over -again. - - -\begin{code} -tcSimplifyInfer - :: SDoc - -> TcTyVarSet -- fv(T); type vars - -> [Inst] -- Wanted - -> TcM ([TcTyVar], -- Tyvars to quantify (zonked and quantified) - [Inst], -- Dict Ids that must be bound here (zonked) - TcDictBinds) -- Bindings - -- Any free (escaping) Insts are tossed into the environment -\end{code} - - -\begin{code} -tcSimplifyInfer doc tau_tvs wanted - = do { tau_tvs1 <- zonkTcTyVarsAndFV (varSetElems tau_tvs) - ; wanted' <- mapM zonkInst wanted -- Zonk before deciding quantified tyvars - ; gbl_tvs <- tcGetGlobalTyVars - ; let preds1 = fdPredsOfInsts wanted' - gbl_tvs1 = oclose preds1 gbl_tvs - qtvs = growInstsTyVars wanted' tau_tvs1 `minusVarSet` gbl_tvs1 - -- See Note [Choosing which variables to quantify] - - -- To maximise sharing, remove from consideration any - -- constraints that don't mention qtvs at all - ; let (free, bound) = partition (isFreeWhenInferring qtvs) wanted' - ; extendLIEs free - - -- To make types simple, reduce as much as possible - ; traceTc (text "infer" <+> (ppr preds1 $$ ppr (growInstsTyVars wanted' tau_tvs1) $$ ppr gbl_tvs $$ - ppr gbl_tvs1 $$ ppr free $$ ppr bound)) - ; (irreds1, binds1) <- tryHardCheckLoop doc bound - - -- Note [Inference and implication constraints] - ; let want_dict d = tyVarsOfInst d `intersectsVarSet` qtvs - ; (irreds2, binds2) <- approximateImplications doc want_dict irreds1 - - -- Now work out all over again which type variables to quantify, - -- exactly in the same way as before, but starting from irreds2. Why? - -- a) By now improvment may have taken place, and we must *not* - -- quantify over any variable free in the environment - -- tc137 (function h inside g) is an example - -- - -- b) Do not quantify over constraints that *now* do not - -- mention quantified type variables, because they are - -- simply ambiguous (or might be bound further out). Example: - -- f :: Eq b => a -> (a, b) - -- g x = fst (f x) - -- From the RHS of g we get the MethodInst f77 :: alpha -> (alpha, beta) - -- We decide to quantify over 'alpha' alone, but free1 does not include f77 - -- because f77 mentions 'alpha'. Then reducing leaves only the (ambiguous) - -- constraint (Eq beta), which we dump back into the free set - -- See test tcfail181 - -- - -- c) irreds may contain type variables not previously mentioned, - -- e.g. instance D a x => Foo [a] - -- wanteds = Foo [a] - -- Then after simplifying we'll get (D a x), and x is fresh - -- We must quantify over x else it'll be totally unbound - ; tau_tvs2 <- zonkTcTyVarsAndFV (varSetElems tau_tvs1) - ; gbl_tvs2 <- zonkTcTyVarsAndFV (varSetElems gbl_tvs1) - -- Note that we start from gbl_tvs1 - -- We use tcGetGlobalTyVars, then oclose wrt preds2, because - -- we've already put some of the original preds1 into frees - -- E.g. wanteds = C a b (where a->b) - -- gbl_tvs = {a} - -- tau_tvs = {b} - -- Then b is fixed by gbl_tvs, so (C a b) will be in free, and - -- irreds2 will be empty. But we don't want to generalise over b! - ; let preds2 = fdPredsOfInsts irreds2 -- irreds2 is zonked - qtvs = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2 - --------------------------------------------------- - -- BUG WARNING: there's a nasty bug lurking here - -- fdPredsOfInsts may return preds that mention variables quantified in - -- one of the implication constraints in irreds2; and that is clearly wrong: - -- we might quantify over too many variables through accidental capture - --------------------------------------------------- - ; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2 - ; extendLIEs free - - -- Turn the quantified meta-type variables into real type variables - ; qtvs2 <- zonkQuantifiedTyVars (varSetElems qtvs) - - -- We can't abstract over any remaining unsolved - -- implications so instead just float them outwards. Ugh. - ; let (q_dicts0, implics) = partition isAbstractableInst irreds3 - ; loc <- getInstLoc (ImplicOrigin doc) - ; implic_bind <- bindIrreds loc qtvs2 q_dicts0 implics - - -- Prepare equality instances for quantification - ; let (q_eqs0,q_dicts) = partition isEqInst q_dicts0 - ; q_eqs <- mapM finalizeEqInst q_eqs0 - - ; return (qtvs2, q_eqs ++ q_dicts, binds1 `unionBags` binds2 `unionBags` implic_bind) } - -- NB: when we are done, we might have some bindings, but - -- the final qtvs might be empty. See Note [NO TYVARS] below. - -approximateImplications :: SDoc -> (Inst -> Bool) -> [Inst] -> TcM ([Inst], TcDictBinds) --- Note [Inference and implication constraints] --- Given a bunch of Dict and ImplicInsts, try to approximate the implications by --- - fetching any dicts inside them that are free --- - using those dicts as cruder constraints, to solve the implications --- - returning the extra ones too - -approximateImplications doc want_dict irreds - | null extra_dicts - = return (irreds, emptyBag) - | otherwise - = do { extra_dicts' <- mapM cloneDict extra_dicts - ; tryHardCheckLoop doc (extra_dicts' ++ irreds) } - -- By adding extra_dicts', we make them - -- available to solve the implication constraints - where - extra_dicts = get_dicts (filter isImplicInst irreds) - - get_dicts :: [Inst] -> [Inst] -- Returns only Dicts - -- Find the wanted constraints in implication constraints that satisfy - -- want_dict, and are not bound by forall's in the constraint itself - get_dicts ds = concatMap get_dict ds - - get_dict d@(Dict {}) | want_dict d = [d] - | otherwise = [] - get_dict (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds}) - = [ d | let tv_set = mkVarSet tvs - , d <- get_dicts wanteds - , not (tyVarsOfInst d `intersectsVarSet` tv_set)] - get_dict i@(EqInst {}) | want_dict i = [i] - | otherwise = [] - get_dict other = pprPanic "approximateImplications" (ppr other) -\end{code} - -Note [Inference and implication constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a wanted implication constraint (perhaps arising from -a nested pattern match) like - C a => D [a] -and we are now trying to quantify over 'a' when inferring the type for -a function. In principle it's possible that there might be an instance - instance (C a, E a) => D [a] -so the context (E a) would suffice. The Right Thing is to abstract over -the implication constraint, but we don't do that (a) because it'll be -surprising to programmers and (b) because we don't have the machinery to deal -with 'given' implications. - -So our best approximation is to make (D [a]) part of the inferred -context, so we can use that to discharge the implication. Hence -the strange function get_dicts in approximateImplications. - -The common cases are more clear-cut, when we have things like - forall a. C a => C b -Here, abstracting over (C b) is not an approximation at all -- but see -Note [Freeness and implications]. - -See Trac #1430 and test tc228. - - -\begin{code} ------------------------------------------------------------ --- tcSimplifyInferCheck is used when we know the constraints we are to simplify --- against, but we don't know the type variables over which we are going to quantify. --- This happens when we have a type signature for a mutually recursive group -tcSimplifyInferCheck - :: InstLoc - -> TcTyVarSet -- fv(T) - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM ([TyVar], -- Fully zonked, and quantified - TcDictBinds) -- Bindings - -tcSimplifyInferCheck loc tau_tvs givens wanteds - = do { traceTc (text "tcSimplifyInferCheck <-" <+> ppr wanteds) - ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - - -- Figure out which type variables to quantify over - -- You might think it should just be the signature tyvars, - -- but in bizarre cases you can get extra ones - -- f :: forall a. Num a => a -> a - -- f x = fst (g (x, head [])) + 1 - -- g a b = (b,a) - -- Here we infer g :: forall a b. a -> b -> (b,a) - -- We don't want g to be monomorphic in b just because - -- f isn't quantified over b. - ; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens) - ; all_tvs <- zonkTcTyVarsAndFV all_tvs - ; gbl_tvs <- tcGetGlobalTyVars - ; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs) - -- We could close gbl_tvs, but its not necessary for - -- soundness, and it'll only affect which tyvars, not which - -- dictionaries, we quantify over - - ; qtvs' <- zonkQuantifiedTyVars qtvs - - -- Now we are back to normal (c.f. tcSimplCheck) - ; implic_bind <- bindIrreds loc qtvs' givens irreds - - ; traceTc (text "tcSimplifyInferCheck ->" <+> ppr (implic_bind)) - ; return (qtvs', binds `unionBags` implic_bind) } -\end{code} - -Note [Squashing methods] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Be careful if you want to float methods more: - truncate :: forall a. RealFrac a => forall b. Integral b => a -> b -From an application (truncate f i) we get - t1 = truncate at f - t2 = t1 at i -If we have also have a second occurrence of truncate, we get - t3 = truncate at f - t4 = t3 at i -When simplifying with i,f free, we might still notice that -t1=t3; but alas, the binding for t2 (which mentions t1) -may continue to float out! - - -Note [NO TYVARS] -~~~~~~~~~~~~~~~~~ - class Y a b | a -> b where - y :: a -> X b - - instance Y [[a]] a where - y ((x:_):_) = X x - - k :: X a -> X a -> X a - - g :: Num a => [X a] -> [X a] - g xs = h xs - where - h ys = ys ++ map (k (y [[0]])) xs - -The excitement comes when simplifying the bindings for h. Initially -try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}. -From this we get t1~t2, but also various bindings. We can't forget -the bindings (because of [LOOP]), but in fact t1 is what g is -polymorphic in. - -The net effect of [NO TYVARS] - -\begin{code} -\end{code} - - -%************************************************************************ -%* * -\subsection{tcSimplifyCheck} -%* * -%************************************************************************ - -@tcSimplifyCheck@ is used when we know exactly the set of variables -we are going to quantify over. For example, a class or instance declaration. - -\begin{code} ------------------------------------------------------------ --- tcSimplifyCheck is used when checking expression type signatures, --- class decls, instance decls etc. -tcSimplifyCheck :: InstLoc - -> [TcTyVar] -- Quantify over these - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -- Bindings -tcSimplifyCheck loc qtvs givens wanteds - = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) - do { traceTc (text "tcSimplifyCheck") - ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - ; implic_bind <- bindIrreds loc qtvs givens irreds - ; return (binds `unionBags` implic_bind) } - ------------------------------------------------------------ --- tcSimplifyCheckPat is used for existential pattern match -tcSimplifyCheckPat :: InstLoc - -> [TcTyVar] -- Quantify over these - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -- Bindings -tcSimplifyCheckPat loc qtvs givens wanteds - = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs ) - do { traceTc (text "tcSimplifyCheckPat") - ; (irreds, binds) <- gentleCheckLoop loc givens wanteds - ; implic_bind <- bindIrredsR loc qtvs givens irreds - ; return (binds `unionBags` implic_bind) } - ------------------------------------------------------------ -bindIrreds :: InstLoc -> [TcTyVar] - -> [Inst] -> [Inst] - -> TcM TcDictBinds -bindIrreds loc qtvs givens irreds - = bindIrredsR loc qtvs givens irreds - -bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds --- Make a binding that binds 'irreds', by generating an implication --- constraint for them, *and* throwing the constraint into the LIE -bindIrredsR loc qtvs givens irreds - | null irreds - = return emptyBag - | otherwise - = do { let givens' = filter isAbstractableInst givens - -- The givens can (redundantly) include methods - -- We want to retain both EqInsts and Dicts - -- There should be no implicadtion constraints - -- See Note [Pruning the givens in an implication constraint] - - -- If there are no 'givens', then it's safe to - -- partition the 'wanteds' by their qtvs, thereby trimming irreds - -- See Note [Freeness and implications] - ; irreds' <- if null givens' - then do - { let qtv_set = mkVarSet qtvs - (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds - ; extendLIEs frees - ; return real_irreds } - else return irreds - - ; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds' - -- This call does the real work - -- If irreds' is empty, it does something sensible - ; extendLIEs implics - ; return bind } - - -makeImplicationBind :: InstLoc -> [TcTyVar] - -> [Inst] -> [Inst] - -> TcM ([Inst], TcDictBinds) --- Make a binding that binds 'irreds', by generating an implication --- constraint for them. --- --- The binding looks like --- (ir1, .., irn) = f qtvs givens --- where f is (evidence for) the new implication constraint --- f :: forall qtvs. givens => (ir1, .., irn) --- qtvs includes coercion variables --- --- This binding must line up the 'rhs' in reduceImplication -makeImplicationBind loc all_tvs - givens -- Guaranteed all Dicts or EqInsts - irreds - | null irreds -- If there are no irreds, we are done - = return ([], emptyBag) - | otherwise -- Otherwise we must generate a binding - = do { uniq <- newUnique - ; span <- getSrcSpanM - ; let (eq_givens, dict_givens) = partition isEqInst givens - - -- extract equality binders - eq_cotvs = map eqInstType eq_givens - - -- make the implication constraint instance - name = mkInternalName uniq (mkVarOcc "ic") span - implic_inst = ImplicInst { tci_name = name, - tci_tyvars = all_tvs, - tci_given = eq_givens ++ dict_givens, - -- same order as binders - tci_wanted = irreds, - tci_loc = loc } - - -- create binders for the irreducible dictionaries - dict_irreds = filter (not . isEqInst) irreds - dict_irred_ids = map instToId dict_irreds - lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids) - - -- create the binding - rhs = L span (mkHsWrap co (HsVar (instToId implic_inst))) - co = mkWpApps (map instToId dict_givens) - <.> mkWpTyApps eq_cotvs - <.> mkWpTyApps (mkTyVarTys all_tvs) - bind | [dict_irred_id] <- dict_irred_ids - = mkVarBind dict_irred_id rhs - | otherwise - = L span $ - PatBind { pat_lhs = lpat - , pat_rhs = unguardedGRHSs rhs - , pat_rhs_ty = hsLPatType lpat - , bind_fvs = placeHolderNames - } - - ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst - ; return ([implic_inst], unitBag bind) - } - ------------------------------------------------------------ -tryHardCheckLoop :: SDoc - -> [Inst] -- Wanted - -> TcM ([Inst], TcDictBinds) - -tryHardCheckLoop doc wanteds - = do { (irreds,binds) <- checkLoop (mkInferRedEnv doc try_me) wanteds - ; return (irreds,binds) - } - where - try_me _ = ReduceMe - -- Here's the try-hard bit - ------------------------------------------------------------ -gentleCheckLoop :: InstLoc - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM ([Inst], TcDictBinds) - -gentleCheckLoop inst_loc givens wanteds - = do { (irreds,binds) <- checkLoop env wanteds - ; return (irreds,binds) - } - where - env = mkRedEnv (pprInstLoc inst_loc) try_me givens - - try_me inst | isMethodOrLit inst = ReduceMe - | otherwise = Stop - -- When checking against a given signature - -- we MUST be very gentle: Note [Check gently] - -gentleInferLoop :: SDoc -> [Inst] - -> TcM ([Inst], TcDictBinds) -gentleInferLoop doc wanteds - = do { (irreds, binds) <- checkLoop env wanteds - ; return (irreds, binds) } - where - env = mkInferRedEnv doc try_me - try_me inst | isMethodOrLit inst = ReduceMe - | otherwise = Stop -\end{code} - -Note [Check gently] -~~~~~~~~~~~~~~~~~~~~ -We have to very careful about not simplifying too vigorously -Example: - data T a where - MkT :: a -> T [a] - - f :: Show b => T b -> b - f (MkT x) = show [x] - -Inside the pattern match, which binds (a:*, x:a), we know that - b ~ [a] -Hence we have a dictionary for Show [a] available; and indeed we -need it. We are going to build an implication contraint - forall a. (b~[a]) => Show [a] -Later, we will solve this constraint using the knowledge (Show b) - -But we MUST NOT reduce (Show [a]) to (Show a), else the whole -thing becomes insoluble. So we simplify gently (get rid of literals -and methods only, plus common up equal things), deferring the real -work until top level, when we solve the implication constraint -with tryHardCheckLooop. - - -\begin{code} ------------------------------------------------------------ -checkLoop :: RedEnv - -> [Inst] -- Wanted - -> TcM ([Inst], TcDictBinds) --- Precondition: givens are completely rigid --- Postcondition: returned Insts are zonked - -checkLoop env wanteds - = go env wanteds - where go env wanteds - = do { -- We do need to zonk the givens; cf Note [Zonking RedEnv] - ; env' <- zonkRedEnv env - ; wanteds' <- zonkInsts wanteds - - ; (improved, tybinds, binds, irreds) - <- reduceContext env' wanteds' - ; execTcTyVarBinds tybinds - - ; if null irreds || not improved then - return (irreds, binds) - else do - - -- If improvement did some unification, we go round again. - -- We start again with irreds, not wanteds - -- Using an instance decl might have introduced a fresh type - -- variable which might have been unified, so we'd get an - -- infinite loop if we started again with wanteds! - -- See Note [LOOP] - { (irreds1, binds1) <- go env' irreds - ; return (irreds1, binds `unionBags` binds1) } } -\end{code} - -Note [Zonking RedEnv] -~~~~~~~~~~~~~~~~~~~~~ -It might appear as if the givens in RedEnv are always rigid, but that is not -necessarily the case for programs involving higher-rank types that have class -contexts constraining the higher-rank variables. An example from tc237 in the -testsuite is - - class Modular s a | s -> a - - wim :: forall a w. Integral a - => a -> (forall s. Modular s a => M s w) -> w - wim i k = error "urk" - - test5 :: (Modular s a, Integral a) => M s a - test5 = error "urk" - - test4 = wim 4 test4' - -Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is -quantified further outside. When type checking test4, we have to check -whether the signature of test5 is an instance of - - (forall s. Modular s a => M s w) - -Consequently, we will get (Modular s t_a), where t_a is a TauTv into the -givens. - -Given the FD of Modular in this example, class improvement will instantiate -t_a to 'a', where 'a' is the skolem from test5's signatures (due to the -Modular s a predicate in that signature). If we don't zonk (Modular s t_a) in -the givens, we will get into a loop as improveOne uses the unification engine -Unify.tcUnifyTys, which doesn't know about mutable type variables. - - -Note [LOOP] -~~~~~~~~~~~ - class If b t e r | b t e -> r - instance If T t e t - instance If F t e e - class Lte a b c | a b -> c where lte :: a -> b -> c - instance Lte Z b T - instance (Lte a b l,If l b a c) => Max a b c - -Wanted: Max Z (S x) y - -Then we'll reduce using the Max instance to: - (Lte Z (S x) l, If l (S x) Z y) -and improve by binding l->T, after which we can do some reduction -on both the Lte and If constraints. What we *can't* do is start again -with (Max Z (S x) y)! - - - -%************************************************************************ -%* * - tcSimplifySuperClasses -%* * -%************************************************************************ - -Note [SUPERCLASS-LOOP 1] -~~~~~~~~~~~~~~~~~~~~~~~~ -We have to be very, very careful when generating superclasses, lest we -accidentally build a loop. Here's an example: - - class S a - - class S a => C a where { opc :: a -> a } - class S b => D b where { opd :: b -> b } - - instance C Int where - opc = opd - - instance D Int where - opd = opc - -From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} -Simplifying, we may well get: - $dfCInt = :C ds1 (opd dd) - dd = $dfDInt - ds1 = $p1 dd -Notice that we spot that we can extract ds1 from dd. - -Alas! Alack! We can do the same for (instance D Int): - - $dfDInt = :D ds2 (opc dc) - dc = $dfCInt - ds2 = $p1 dc - -And now we've defined the superclass in terms of itself. -Two more nasty cases are in - tcrun021 - tcrun033 - -Solution: - - Satisfy the superclass context *all by itself* - (tcSimplifySuperClasses) - - And do so completely; i.e. no left-over constraints - to mix with the constraints arising from method declarations - - -Note [Recursive instances and superclases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this code, which arises in the context of "Scrap Your -Boilerplate with Class". - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) - - instance Data Maybe a => Foo a - instance Foo a => Foo [a] - instance Foo [Char] - -In the instance for Foo [a], when generating evidence for the superclasses -(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]). -Using the instance for Data, we therefore need - (Sat (Maybe [a], Data Maybe a) -But we are given (Foo a), and hence its superclass (Data Maybe a). -So that leaves (Sat (Maybe [a])). Using the instance for Sat means -we need (Foo [a]). And that is the very dictionary we are bulding -an instance for! So we must put that in the "givens". So in this -case we have - Given: Foo a, Foo [a] - Watend: Data Maybe [a] - -BUT we must *not not not* put the *superclasses* of (Foo [a]) in -the givens, which is what 'addGiven' would normally do. Why? Because -(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted -by selecting a superclass from Foo [a], which simply makes a loop. - -On the other hand we *must* put the superclasses of (Foo a) in -the givens, as you can see from the derivation described above. - -Conclusion: in the very special case of tcSimplifySuperClasses -we have one 'given' (namely the "this" dictionary) whose superclasses -must not be added to 'givens' by addGiven. - -There is a complication though. Suppose there are equalities - instance (Eq a, a~b) => Num (a,b) -Then we normalise the 'givens' wrt the equalities, so the original -given "this" dictionary is cast to one of a different type. So it's a -bit trickier than before to identify the "special" dictionary whose -superclasses must not be added. See test - indexed-types/should_run/EqInInstance - -We need a persistent property of the dictionary to record this -special-ness. Current I'm using the InstLocOrigin (a bit of a hack, -but cool), which is maintained by dictionary normalisation. -Specifically, the InstLocOrigin is - NoScOrigin -then the no-superclass thing kicks in. WATCH OUT if you fiddle -with InstLocOrigin! - -\begin{code} -tcSimplifySuperClasses - :: InstLoc - -> Inst -- The dict whose superclasses - -- are being figured out - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -tcSimplifySuperClasses loc this givens sc_wanteds - = do { traceTc (text "tcSimplifySuperClasses") - - -- Note [Recursive instances and superclases] - ; no_sc_loc <- getInstLoc NoScOrigin - ; let no_sc_this = setInstLoc this no_sc_loc - - ; let env = RedEnv { red_doc = pprInstLoc loc, - red_try_me = try_me, - red_givens = no_sc_this : givens, - red_stack = (0,[]), - red_improve = False } -- No unification vars - - - ; (irreds,binds1) <- checkLoop env sc_wanteds - ; let (tidy_env, tidy_irreds) = tidyInsts irreds - ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds - ; return binds1 } - where - try_me _ = ReduceMe -- Try hard, so we completely solve the superclass - -- constraints right here. See Note [SUPERCLASS-LOOP 1] -\end{code} - - -%************************************************************************ -%* * -\subsection{tcSimplifyRestricted} -%* * -%************************************************************************ - -tcSimplifyRestricted infers which type variables to quantify for a -group of restricted bindings. This isn't trivial. - -Eg1: id = \x -> x - We want to quantify over a to get id :: forall a. a->a - -Eg2: eq = (==) - We do not want to quantify over a, because there's an Eq a - constraint, so we get eq :: a->a->Bool (notice no forall) - -So, assume: - RHS has type 'tau', whose free tyvars are tau_tvs - RHS has constraints 'wanteds' - -Plan A (simple) - Quantify over (tau_tvs \ ftvs(wanteds)) - This is bad. The constraints may contain (Monad (ST s)) - where we have instance Monad (ST s) where... - so there's no need to be monomorphic in s! - - Also the constraint might be a method constraint, - whose type mentions a perfectly innocent tyvar: - op :: Num a => a -> b -> a - Here, b is unconstrained. A good example would be - foo = op (3::Int) - We want to infer the polymorphic type - foo :: forall b. b -> b - - -Plan B (cunning, used for a long time up to and including GHC 6.2) - Step 1: Simplify the constraints as much as possible (to deal - with Plan A's problem). Then set - qtvs = tau_tvs \ ftvs( simplify( wanteds ) ) - - Step 2: Now simplify again, treating the constraint as 'free' if - it does not mention qtvs, and trying to reduce it otherwise. - The reasons for this is to maximise sharing. - - This fails for a very subtle reason. Suppose that in the Step 2 - a constraint (Foo (Succ Zero) (Succ Zero) b) gets thrown upstairs as 'free'. - In the Step 1 this constraint might have been simplified, perhaps to - (Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'. - This won't happen in Step 2... but that in turn might prevent some other - constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..}) - and that in turn breaks the invariant that no constraints are quantified over. - - Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates - the problem. - - -Plan C (brutal) - Step 1: Simplify the constraints as much as possible (to deal - with Plan A's problem). Then set - qtvs = tau_tvs \ ftvs( simplify( wanteds ) ) - Return the bindings from Step 1. - - -A note about Plan C (arising from "bug" reported by George Russel March 2004) -Consider this: - - instance (HasBinary ty IO) => HasCodedValue ty - - foo :: HasCodedValue a => String -> IO a - - doDecodeIO :: HasCodedValue a => () -> () -> IO a - doDecodeIO codedValue view - = let { act = foo "foo" } in act - -You might think this should work becuase the call to foo gives rise to a constraint -(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO. But the -restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the -constraint using the (rather bogus) instance declaration, and now we are stuffed. - -I claim this is not really a bug -- but it bit Sergey as well as George. So here's -plan D - - -Plan D (a variant of plan B) - Step 1: Simplify the constraints as much as possible (to deal - with Plan A's problem), BUT DO NO IMPROVEMENT. Then set - qtvs = tau_tvs \ ftvs( simplify( wanteds ) ) - - Step 2: Now simplify again, treating the constraint as 'free' if - it does not mention qtvs, and trying to reduce it otherwise. - - The point here is that it's generally OK to have too few qtvs; that is, - to make the thing more monomorphic than it could be. We don't want to - do that in the common cases, but in wierd cases it's ok: the programmer - can always add a signature. - - Too few qtvs => too many wanteds, which is what happens if you do less - improvement. - - -\begin{code} -tcSimplifyRestricted -- Used for restricted binding groups - -- i.e. ones subject to the monomorphism restriction - :: SDoc - -> TopLevelFlag - -> [Name] -- Things bound in this group - -> TcTyVarSet -- Free in the type of the RHSs - -> [Inst] -- Free in the RHSs - -> TcM ([TyVar], -- Tyvars to quantify (zonked and quantified) - TcDictBinds) -- Bindings - -- tcSimpifyRestricted returns no constraints to - -- quantify over; by definition there are none. - -- They are all thrown back in the LIE - -tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds - -- Zonk everything in sight - = do { traceTc (text "tcSimplifyRestricted") - ; wanteds_z <- zonkInsts wanteds - - -- 'ReduceMe': Reduce as far as we can. Don't stop at - -- dicts; the idea is to get rid of as many type - -- variables as possible, and we don't want to stop - -- at (say) Monad (ST s), because that reduces - -- immediately, with no constraint on s. - -- - -- BUT do no improvement! See Plan D above - -- HOWEVER, some unification may take place, if we instantiate - -- a method Inst with an equality constraint - ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe) - ; (_imp, _tybinds, _binds, constrained_dicts) - <- reduceContext env wanteds_z - - -- Next, figure out the tyvars we will quantify over - ; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs) - ; gbl_tvs' <- tcGetGlobalTyVars - ; constrained_dicts' <- zonkInsts constrained_dicts - - ; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs' - -- As in tcSimplifyInfer - - -- Do not quantify over constrained type variables: - -- this is the monomorphism restriction - constrained_tvs' = tyVarsOfInsts constrained_dicts' - qtvs = qtvs1 `minusVarSet` constrained_tvs' - pp_bndrs = pprWithCommas (quotes . ppr) bndrs - - -- Warn in the mono - ; warn_mono <- doptM Opt_WarnMonomorphism - ; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1)) - (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding") - <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs, - ptext (sLit "Consider giving a type signature for") <+> pp_bndrs]) - - ; traceTc (text "tcSimplifyRestricted" <+> vcat [ - pprInsts wanteds, pprInsts constrained_dicts', - ppr _binds, - ppr constrained_tvs', ppr tau_tvs', ppr qtvs ]) - - -- The first step may have squashed more methods than - -- necessary, so try again, this time more gently, knowing the exact - -- set of type variables to quantify over. - -- - -- We quantify only over constraints that are captured by qtvs; - -- these will just be a subset of non-dicts. This in contrast - -- to normal inference (using isFreeWhenInferring) in which we quantify over - -- all *non-inheritable* constraints too. This implements choice - -- (B) under "implicit parameter and monomorphism" above. - -- - -- Remember that we may need to do *some* simplification, to - -- (for example) squash {Monad (ST s)} into {}. It's not enough - -- just to float all constraints - -- - -- At top level, we *do* squash methods because we want to - -- expose implicit parameters to the test that follows - ; let is_nested_group = isNotTopLevel top_lvl - try_me inst | isFreeWrtTyVars qtvs inst, - (is_nested_group || isDict inst) = Stop - | otherwise = ReduceMe - env = mkNoImproveRedEnv doc try_me - ; (_imp, tybinds, binds, irreds) <- reduceContext env wanteds_z - ; execTcTyVarBinds tybinds - - -- See "Notes on implicit parameters, Question 4: top level" - ; ASSERT( all (isFreeWrtTyVars qtvs) irreds ) -- None should be captured - if is_nested_group then - extendLIEs irreds - else do { let (bad_ips, non_ips) = partition isIPDict irreds - ; addTopIPErrs bndrs bad_ips - ; extendLIEs non_ips } - - ; qtvs' <- zonkQuantifiedTyVars (varSetElems qtvs) - ; return (qtvs', binds) } -\end{code} - - -%************************************************************************ -%* * - tcSimplifyRuleLhs -%* * -%************************************************************************ - -On the LHS of transformation rules we only simplify methods and constants, -getting dictionaries. We want to keep all of them unsimplified, to serve -as the available stuff for the RHS of the rule. - -Example. Consider the following left-hand side of a rule - - f (x == y) (y > z) = ... - -If we typecheck this expression we get constraints - - d1 :: Ord a, d2 :: Eq a - -We do NOT want to "simplify" to the LHS - - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... - -Instead we want - - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... - -Here is another example: - - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} - -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int - -because the scsel will mess up RULE matching. Instead we want - - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - - g (x == y) (y == z) = .. - -where the two dictionaries are *identical*, we do NOT WANT - - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... - -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, tcSimplifyRuleLhs must *only* squash LitInst and MethInts, leaving -all dicts unchanged, with absolutely no sharing. It's simpler to do this -from scratch, rather than further parameterise simpleReduceLoop etc. -Simpler, maybe, but alas not simple (see Trac #2494) - -* Type errors may give rise to an (unsatisfiable) equality constraint - -* Applications of a higher-rank function on the LHS may give - rise to an implication constraint, esp if there are unsatisfiable - equality constraints inside. - -\begin{code} -tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds) -tcSimplifyRuleLhs wanteds - = do { wanteds' <- zonkInsts wanteds - - -- Simplify equalities - -- It's important to do this: Trac #3346 for example - ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds' - ; execTcTyVarBinds tybinds - - -- Simplify other constraints - ; (irreds, binds2) <- go [] emptyBag wanteds'' - - -- Report anything that is left - ; let (dicts, bad_irreds) = partition isDict irreds - ; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds) - ; addNoInstanceErrs (nub bad_irreds) - -- The nub removes duplicates, which has - -- not happened otherwise (see notes above) - - ; return (dicts, binds1 `unionBags` binds2) } - where - go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds) - go irreds binds [] - = return (irreds, binds) - go irreds binds (w:ws) - | isDict w - = go (w:irreds) binds ws - | isImplicInst w -- Have a go at reducing the implication - = do { (binds1, irreds1) <- reduceImplication red_env w - ; let (bad_irreds, ok_irreds) = partition isImplicInst irreds1 - ; go (bad_irreds ++ irreds) - (binds `unionBags` binds1) - (ok_irreds ++ ws)} - | otherwise - = do { w' <- zonkInst w -- So that (3::Int) does not generate a call - -- to fromInteger; this looks fragile to me - ; lookup_result <- lookupSimpleInst w' - ; case lookup_result of - NoInstance -> go (w:irreds) binds ws - GenInst ws' rhs -> go irreds binds' (ws' ++ ws) - where - binds' = addInstToDictBind binds w rhs - } - - -- Sigh: we need to reduce inside implications - red_env = mkInferRedEnv doc try_me - doc = ptext (sLit "Implication constraint in RULE lhs") - try_me inst | isMethodOrLit inst = ReduceMe - | otherwise = Stop -- Be gentle -\end{code} - -tcSimplifyBracket is used when simplifying the constraints arising from -a Template Haskell bracket [| ... |]. We want to check that there aren't -any constraints that can't be satisfied (e.g. Show Foo, where Foo has no -Show instance), but we aren't otherwise interested in the results. -Nor do we care about ambiguous dictionaries etc. We will type check -this bracket again at its usage site. - -\begin{code} -tcSimplifyBracket :: [Inst] -> TcM () -tcSimplifyBracket wanteds - = do { _ <- tryHardCheckLoop doc wanteds - ; return () } - where - doc = text "tcSimplifyBracket" -\end{code} - - -%************************************************************************ -%* * -\subsection{Filtering at a dynamic binding} -%* * -%************************************************************************ - -When we have - let ?x = R in B - -we must discharge all the ?x constraints from B. We also do an improvement -step; if we have ?x::t1 and ?x::t2 we must unify t1, t2. - -Actually, the constraints from B might improve the types in ?x. For example - - f :: (?x::Int) => Char -> Char - let ?x = 3 in f 'c' - -then the constraint (?x::Int) arising from the call to f will -force the binding for ?x to be of type Int. - -\begin{code} -tcSimplifyIPs :: [Inst] -- The implicit parameters bound here - -> [Inst] -- Wanted - -> TcM TcDictBinds - -- We need a loop so that we do improvement, and then - -- (next time round) generate a binding to connect the two - -- let ?x = e in ?x - -- Here the two ?x's have different types, and improvement - -- makes them the same. - -tcSimplifyIPs given_ips wanteds - = do { wanteds' <- zonkInsts wanteds - ; given_ips' <- zonkInsts given_ips - -- Unusually for checking, we *must* zonk the given_ips - - ; let env = mkRedEnv doc try_me given_ips' - ; (improved, tybinds, binds, irreds) <- reduceContext env wanteds' - ; execTcTyVarBinds tybinds - - ; if null irreds || not improved then - ASSERT( all is_free irreds ) - do { extendLIEs irreds - ; return binds } - else do - -- If improvement did some unification, we go round again. - -- We start again with irreds, not wanteds - -- Using an instance decl might have introduced a fresh type - -- variable which might have been unified, so we'd get an - -- infinite loop if we started again with wanteds! - -- See Note [LOOP] - { binds1 <- tcSimplifyIPs given_ips' irreds - ; return $ binds `unionBags` binds1 - } } - where - doc = text "tcSimplifyIPs" <+> ppr given_ips - ip_set = mkNameSet (ipNamesOfInsts given_ips) - is_free inst = isFreeWrtIPs ip_set inst - - -- Simplify any methods that mention the implicit parameter - try_me inst | is_free inst = Stop - | otherwise = ReduceMe -\end{code} - - -%************************************************************************ -%* * -\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@} -%* * -%************************************************************************ - -When doing a binding group, we may have @Insts@ of local functions. -For example, we might have... -\begin{verbatim} -let f x = x + 1 -- orig local function (overloaded) - f.1 = f Int -- two instances of f - f.2 = f Float - in - (f.1 5, f.2 6.7) -\end{verbatim} -The point is: we must drop the bindings for @f.1@ and @f.2@ here, -where @f@ is in scope; those @Insts@ must certainly not be passed -upwards towards the top-level. If the @Insts@ were binding-ified up -there, they would have unresolvable references to @f@. - -We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@. -For each method @Inst@ in the @init_lie@ that mentions one of the -@Ids@, we create a binding. We return the remaining @Insts@ (in an -@LIE@), as well as the @HsBinds@ generated. - -\begin{code} -bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcDictBinds --- Simlifies only MethodInsts, and generate only bindings of form --- fm = f tys dicts --- We're careful not to even generate bindings of the form --- d1 = d2 --- You'd think that'd be fine, but it interacts with what is --- arguably a bug in Match.tidyEqnInfo (see notes there) - -bindInstsOfLocalFuns wanteds local_ids - | null overloaded_ids = do - -- Common case - extendLIEs wanteds - return emptyLHsBinds - - | otherwise - = do { (irreds, binds) <- gentleInferLoop doc for_me - ; extendLIEs not_for_me - ; extendLIEs irreds - ; return binds } - where - doc = text "bindInsts" <+> ppr local_ids - overloaded_ids = filter is_overloaded local_ids - is_overloaded id = isOverloadedTy (idType id) - (for_me, not_for_me) = partition (isMethodFor overloaded_set) wanteds - - overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them - -- so it's worth building a set, so that - -- lookup (in isMethodFor) is faster -\end{code} - - -%************************************************************************ -%* * -\subsection{Data types for the reduction mechanism} -%* * -%************************************************************************ - -The main control over context reduction is here - -\begin{code} -data RedEnv - = RedEnv { red_doc :: SDoc -- The context - , red_try_me :: Inst -> WhatToDo - , red_improve :: Bool -- True <=> do improvement - , red_givens :: [Inst] -- All guaranteed rigid - -- Always dicts & equalities - -- but see Note [Rigidity] - - , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) - -- See Note [RedStack] - } - --- Note [Rigidity] --- The red_givens are rigid so far as cmpInst is concerned. --- There is one case where they are not totally rigid, namely in tcSimplifyIPs --- let ?x = e in ... --- Here, the given is (?x::a), where 'a' is not necy a rigid type --- But that doesn't affect the comparison, which is based only on mame. - --- Note [RedStack] --- The red_stack pair (n,insts) pair is just used for error reporting. --- 'n' is always the depth of the stack. --- The 'insts' is the stack of Insts being reduced: to produce X --- I had to produce Y, to produce Y I had to produce Z, and so on. - - -mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv -mkRedEnv doc try_me givens - = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = givens, - red_stack = (0,[]), - red_improve = True } - -mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv --- No givens at all -mkInferRedEnv doc try_me - = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = [], - red_stack = (0,[]), - red_improve = True } - -mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv --- Do not do improvement; no givens -mkNoImproveRedEnv doc try_me - = RedEnv { red_doc = doc, red_try_me = try_me, - red_givens = [], - red_stack = (0,[]), - red_improve = True } - -data WhatToDo - = ReduceMe -- Try to reduce this - -- If there's no instance, add the inst to the - -- irreductible ones, but don't produce an error - -- message of any kind. - -- It might be quite legitimate such as (Eq a)! - - | Stop -- Return as irreducible unless it can - -- be reduced to a constant in one step - -- Do not add superclasses; see - -data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses - -- of a predicate when adding it to the avails - -- The reason for this flag is entirely the super-class loop problem - -- Note [SUPER-CLASS LOOP 1] - -zonkRedEnv :: RedEnv -> TcM RedEnv -zonkRedEnv env - = do { givens' <- mapM zonkInst (red_givens env) - ; return $ env {red_givens = givens'} - } -\end{code} - - -%************************************************************************ -%* * -\subsection[reduce]{@reduce@} -%* * -%************************************************************************ - -Note [Ancestor Equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -During context reduction, we add to the wanted equalities also those -equalities that (transitively) occur in superclass contexts of wanted -class constraints. Consider the following code - - class a ~ Int => C a - instance C Int - -If (C a) is wanted, we want to add (a ~ Int), which will be discharged by -substituting Int for a. Hence, we ultimately want (C Int), which we -discharge with the explicit instance. - -\begin{code} -reduceContext :: RedEnv - -> [Inst] -- Wanted - -> TcM (ImprovementDone, - TcTyVarBinds, -- Type variable bindings - TcDictBinds, -- Dictionary bindings - [Inst]) -- Irreducible - -reduceContext env wanteds0 - = do { traceTc (text "reduceContext" <+> (vcat [ - text "----------------------", - red_doc env, - text "given" <+> ppr (red_givens env), - text "wanted" <+> ppr wanteds0, - text "----------------------" - ])) - - -- We want to add as wanted equalities those that (transitively) - -- occur in superclass contexts of wanted class constraints. - -- See Note [Ancestor Equalities] - ; ancestor_eqs <- ancestorEqualities wanteds0 - ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs - - -- Normalise and solve all equality constraints as far as possible - -- and normalise all dictionary constraints wrt to the reduced - -- equalities. The returned wanted constraints include the - -- irreducible wanted equalities. - ; let wanteds = wanteds0 ++ ancestor_eqs - givens = red_givens env - ; (givens', - wanteds', - tybinds, - normalise_binds) <- tcReduceEqs givens wanteds - ; traceTc $ text "reduceContext: tcReduceEqs result" <+> vcat - [ppr givens', ppr wanteds', ppr tybinds, - ppr normalise_binds] - - -- Build the Avail mapping from "given_dicts" - ; (init_state, _) <- getConstraints $ do - { init_state <- foldlM addGiven emptyAvails givens' - ; return init_state - } - - -- Solve the *wanted* *dictionary* constraints (not implications) - -- This may expose some further equational constraints in the course - -- of improvement due to functional dependencies if any of the - -- involved unifications gets deferred. - ; let (wanted_implics, wanted_dicts) = partition isImplicInst wanteds' - ; (avails, extra_eqs) <- getConstraints (reduceList env wanted_dicts init_state) - -- The getConstraints is reqd because reduceList does improvement - -- (via extendAvails) which may in turn do unification - ; (dict_binds, - bound_dicts, - dict_irreds) <- extractResults avails wanted_dicts - ; traceTc $ text "reduceContext: extractResults" <+> vcat - [ppr avails, ppr wanted_dicts, ppr dict_binds] - - -- Solve the wanted *implications*. In doing so, we can provide - -- as "given" all the dicts that were originally given, - -- *or* for which we now have bindings, - -- *or* which are now irreds - -- NB: Equality irreds need to be converted, as the recursive - -- invocation of the solver will still treat them as wanteds - -- otherwise. - ; let implic_env = env { red_givens - = givens ++ bound_dicts ++ - map wantedToLocalEqInst dict_irreds } - ; (implic_binds_s, implic_irreds_s) - <- mapAndUnzipM (reduceImplication implic_env) wanted_implics - ; let implic_binds = unionManyBags implic_binds_s - implic_irreds = concat implic_irreds_s - - -- Collect all irreducible instances, and determine whether we should - -- go round again. We do so in either of two cases: - -- (1) If dictionary reduction or equality solving led to - -- improvement (i.e., bindings for type variables). - -- (2) If we reduced dictionaries (i.e., got dictionary bindings), - -- they may have exposed further opportunities to normalise - -- family applications. See Note [Dictionary Improvement] - -- - -- NB: We do *not* go around for new extra_eqs. Morally, we should, - -- but we can't without risking non-termination (see #2688). By - -- not going around, we miss some legal programs mixing FDs and - -- TFs, but we never claimed to support such programs in the - -- current implementation anyway. - - ; let all_irreds = dict_irreds ++ implic_irreds ++ extra_eqs - avails_improved = availsImproved avails - eq_improved = anyBag (not . isCoVarBind) tybinds - improvedFlexible = avails_improved || eq_improved - reduced_dicts = not (isEmptyBag dict_binds) - improved = improvedFlexible || reduced_dicts - -- - improvedHint = (if avails_improved then " [AVAILS]" else "") ++ - (if eq_improved then " [EQ]" else "") - - ; traceTc (text "reduceContext end" <+> (vcat [ - text "----------------------", - red_doc env, - text "given" <+> ppr givens, - text "wanted" <+> ppr wanteds0, - text "----", - text "tybinds" <+> ppr tybinds, - text "avails" <+> pprAvails avails, - text "improved =" <+> ppr improved <+> text improvedHint, - text "(all) irreds = " <+> ppr all_irreds, - text "dict-binds = " <+> ppr dict_binds, - text "implic-binds = " <+> ppr implic_binds, - text "----------------------" - ])) - - ; return (improved, - tybinds, - normalise_binds `unionBags` dict_binds - `unionBags` implic_binds, - all_irreds) - } - where - isCoVarBind (TcTyVarBind tv _) = isCoVar tv - -tcImproveOne :: Avails -> Inst -> TcM ImprovementDone -tcImproveOne avails inst - | not (isDict inst) = return False - | otherwise - = do { inst_envs <- tcGetInstEnvs - ; let eqns = improveOne (classInstances inst_envs) - (dictPred inst, pprInstArising inst) - [ (dictPred p, pprInstArising p) - | p <- availsInsts avails, isDict p ] - -- Avails has all the superclasses etc (good) - -- It also has all the intermediates of the deduction (good) - -- It does not have duplicates (good) - -- NB that (?x::t1) and (?x::t2) will be held separately in - -- avails so that improve will see them separate - ; traceTc (text "improveOne" <+> ppr inst) - ; unifyEqns eqns } - -unifyEqns :: [(Equation, (PredType, SDoc), (PredType, SDoc))] - -> TcM ImprovementDone -unifyEqns [] = return False -unifyEqns eqns - = do { traceTc (ptext (sLit "Improve:") <+> vcat (map pprEquationDoc eqns)) - ; improved <- mapM unify eqns - ; return $ or improved - } - where - unify ((qtvs, pairs), what1, what2) - = addErrCtxtM (mkEqnMsg what1 what2) $ - do { let freeTyVars = unionVarSets (map tvs_pr pairs) - `minusVarSet` qtvs - ; (_, _, tenv) <- tcInstTyVars (varSetElems qtvs) - ; mapM_ (unif_pr tenv) pairs - ; anyM isFilledMetaTyVar $ varSetElems freeTyVars - } - - unif_pr tenv (ty1, ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2) - - tvs_pr (ty1, ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 - -pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc -pprEquationDoc (eqn, (p1, _), (p2, _)) - = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)] - -mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv - -> TcM (TidyEnv, SDoc) -mkEqnMsg (pred1,from1) (pred2,from2) tidy_env - = do { pred1' <- zonkTcPredType pred1 - ; pred2' <- zonkTcPredType pred2 - ; let { pred1'' = tidyPred tidy_env pred1' - ; pred2'' = tidyPred tidy_env pred2' } - ; let msg = vcat [ptext (sLit "When using functional dependencies to combine"), - nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), - nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])] - ; return (tidy_env, msg) } -\end{code} - -Note [Dictionary Improvement] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In reduceContext, we first reduce equalities and then class constraints. -However, the letter may expose further opportunities for the former. Hence, -we need to go around again if dictionary reduction produced any dictionary -bindings. The following example demonstrated the point: - - data EX _x _y (p :: * -> *) - data ANY - - class Base p - - class Base (Def p) => Prop p where - type Def p - - instance Base () - instance Prop () where - type Def () = () - - instance (Base (Def (p ANY))) => Base (EX _x _y p) - instance (Prop (p ANY)) => Prop (EX _x _y p) where - type Def (EX _x _y p) = EX _x _y p - - data FOO x - instance Prop (FOO x) where - type Def (FOO x) = () - - data BAR - instance Prop BAR where - type Def BAR = EX () () FOO - -During checking the last instance declaration, we need to check the superclass -cosntraint Base (Def BAR), which family normalisation reduced to -Base (EX () () FOO). Chasing the instance for Base (EX _x _y p), gives us -Base (Def (FOO ANY)), which again requires family normalisation of Def to -Base () before we can finish. - - -The main context-reduction function is @reduce@. Here's its game plan. - -\begin{code} -reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails -reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state - = do { traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state)) - ; dopts <- getDOpts - ; when (debugIsOn && (n > 8)) $ do - debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n) - 2 (ifPprDebug (nest 2 (pprStack stk)))) - ; if n >= ctxtStkDepth dopts then - failWithTc (reduceDepthErr n stk) - else - go wanteds state } - where - go [] state = return state - go (w:ws) state = do { state' <- reduce (env {red_stack = (n+1, w:stk)}) w state - ; go ws state' } - - -- Base case: we're done! -reduce :: RedEnv -> Inst -> Avails -> TcM Avails -reduce env wanted avails - - -- We don't reduce equalities here (and they must not end up as irreds - -- in the Avails!) - | isEqInst wanted - = return avails - - -- It's the same as an existing inst, or a superclass thereof - | Just _ <- findAvail avails wanted - = do { traceTc (text "reduce: found " <+> ppr wanted) - ; return avails - } - - | otherwise - = do { traceTc (text "reduce" <+> ppr wanted $$ ppr avails) - ; case red_try_me env wanted of { - Stop -> try_simple (addIrred NoSCs); - -- See Note [No superclasses for Stop] - - ReduceMe -> do -- It should be reduced - { (avails, lookup_result) <- reduceInst env avails wanted - ; case lookup_result of - NoInstance -> addIrred AddSCs avails wanted - -- Add it and its superclasses - - GenInst [] rhs -> addWanted AddSCs avails wanted rhs [] - - GenInst wanteds' rhs - -> do { avails1 <- addIrred NoSCs avails wanted - ; avails2 <- reduceList env wanteds' avails1 - ; addWanted AddSCs avails2 wanted rhs wanteds' } } - -- Temporarily do addIrred *before* the reduceList, - -- which has the effect of adding the thing we are trying - -- to prove to the database before trying to prove the things it - -- needs. See note [RECURSIVE DICTIONARIES] - -- NB: we must not do an addWanted before, because that adds the - -- superclasses too, and that can lead to a spurious loop; see - -- the examples in [SUPERCLASS-LOOP] - -- So we do an addIrred before, and then overwrite it afterwards with addWanted - } } - where - -- First, see if the inst can be reduced to a constant in one step - -- Works well for literals (1::Int) and constant dictionaries (d::Num Int) - -- Don't bother for implication constraints, which take real work - try_simple do_this_otherwise - = do { res <- lookupSimpleInst wanted - ; case res of - GenInst [] rhs -> addWanted AddSCs avails wanted rhs [] - _ -> do_this_otherwise avails wanted } -\end{code} - - -Note [RECURSIVE DICTIONARIES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - d1 : Eq (D []) - -by instance decl, holds if - d2 : Eq [D []] - where d1 = dfEqD d2 - -by instance decl of Eq, holds if - d3 : D [] - where d2 = dfEqList d3 - d1 = dfEqD d2 - -But now we can "tie the knot" to give - - d3 = d1 - d2 = dfEqList d3 - d1 = dfEqD d2 - -and it'll even run! The trick is to put the thing we are trying to prove -(in this case Eq (D []) into the database before trying to prove its -contributing clauses. - -Note [SUPERCLASS-LOOP 2] -~~~~~~~~~~~~~~~~~~~~~~~~ -We need to be careful when adding "the constaint we are trying to prove". -Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the -superclasses of C [a] to avails. But we must not overwrite the binding -for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just -build a loop! - -Here's another variant, immortalised in tcrun020 - class Monad m => C1 m - class C1 m => C2 m x - instance C2 Maybe Bool -For the instance decl we need to build (C1 Maybe), and it's no good if -we run around and add (C2 Maybe Bool) and its superclasses to the avails -before we search for C1 Maybe. - -Here's another example - class Eq b => Foo a b - instance Eq a => Foo [a] a -If we are reducing - (Foo [t] t) - -we'll first deduce that it holds (via the instance decl). We must not -then overwrite the Eq t constraint with a superclass selection! - -At first I had a gross hack, whereby I simply did not add superclass constraints -in addWanted, though I did for addGiven and addIrred. This was sub-optimal, -becuase it lost legitimate superclass sharing, and it still didn't do the job: -I found a very obscure program (now tcrun021) in which improvement meant the -simplifier got two bites a the cherry... so something seemed to be an Stop -first time, but reducible next time. - -Now we implement the Right Solution, which is to check for loops directly -when adding superclasses. It's a bit like the occurs check in unification. - - - -%************************************************************************ -%* * - Reducing a single constraint -%* * -%************************************************************************ - -\begin{code} ---------------------------------------------- -reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult) -reduceInst _ avails other_inst - = do { result <- lookupSimpleInst other_inst - ; return (avails, result) } -\end{code} - -Note [Equational Constraints in Implication Constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -An implication constraint is of the form - Given => Wanted -where Given and Wanted may contain both equational and dictionary -constraints. The delay and reduction of these two kinds of constraints -is distinct: - --) In the generated code, wanted Dictionary constraints are wrapped up in an - implication constraint that is created at the code site where the wanted - dictionaries can be reduced via a let-binding. This let-bound implication - constraint is deconstructed at the use-site of the wanted dictionaries. - --) While the reduction of equational constraints is also delayed, the delay - is not manifest in the generated code. The required evidence is generated - in the code directly at the use-site. There is no let-binding and deconstruction - necessary. The main disadvantage is that we cannot exploit sharing as the - same evidence may be generated at multiple use-sites. However, this disadvantage - is limited because it only concerns coercions which are erased. - -The different treatment is motivated by the different in representation. Dictionary -constraints require manifest runtime dictionaries, while equations require coercions -which are types. - -\begin{code} ---------------------------------------------- -reduceImplication :: RedEnv - -> Inst - -> TcM (TcDictBinds, [Inst]) -\end{code} - -Suppose we are simplifying the constraint - forall bs. extras => wanted -in the context of an overall simplification problem with givens 'givens'. - -Note that - * The 'givens' need not mention any of the quantified type variables - e.g. forall {}. Eq a => Eq [a] - forall {}. C Int => D (Tree Int) - - This happens when you have something like - data T a where - T1 :: Eq a => a -> T a - - f :: T a -> Int - f x = ...(case x of { T1 v -> v==v })... - -\begin{code} - -- ToDo: should we instantiate tvs? I think it's not necessary - -- - -- Note on coercion variables: - -- - -- The extra given coercion variables are bound at two different - -- sites: - -- - -- -) in the creation context of the implication constraint - -- the solved equational constraints use these binders - -- - -- -) at the solving site of the implication constraint - -- the solved dictionaries use these binders; - -- these binders are generated by reduceImplication - -- - -- Note [Binders for equalities] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- To reuse the binders of local/given equalities in the binders of - -- implication constraints, it is crucial that these given equalities - -- always have the form - -- cotv :: t1 ~ t2 - -- where cotv is a simple coercion type variable (and not a more - -- complex coercion term). We require that the extra_givens always - -- have this form and exploit the special form when generating binders. -reduceImplication env - orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc, - tci_tyvars = tvs, - tci_given = extra_givens, tci_wanted = wanteds - }) - = do { -- Solve the sub-problem - ; let try_me _ = ReduceMe -- Note [Freeness and implications] - env' = env { red_givens = extra_givens ++ red_givens env - , red_doc = sep [ptext (sLit "reduceImplication for") - <+> ppr name, - nest 2 (parens $ ptext (sLit "within") - <+> red_doc env)] - , red_try_me = try_me } - - ; traceTc (text "reduceImplication" <+> vcat - [ ppr (red_givens env), ppr extra_givens, - ppr wanteds]) - ; (irreds, binds) <- checkLoop env' wanteds - - ; traceTc (text "reduceImplication result" <+> vcat - [ppr irreds, ppr binds]) - - ; -- extract superclass binds - -- (sc_binds,_) <- extractResults avails [] --- ; traceTc (text "reduceImplication sc_binds" <+> vcat --- [ppr sc_binds, ppr avails]) --- - - -- SLPJ Sept 07: what if improvement happened inside the checkLoop? - -- Then we must iterate the outer loop too! - - ; didntSolveWantedEqs <- allM wantedEqInstIsUnsolved wanteds - -- we solve wanted eqs by side effect! - - -- Progress is no longer measered by the number of bindings - -- If there are any irreds, but no bindings and no solved - -- equalities, we back off and do nothing - ; let backOff = isEmptyLHsBinds binds && -- no new bindings - (not $ null irreds) && -- but still some irreds - didntSolveWantedEqs -- no instantiated cotv - - ; if backOff then -- No progress - return (emptyBag, [orig_implic]) - else do - { (simpler_implic_insts, bind) - <- makeImplicationBind inst_loc tvs extra_givens irreds - -- This binding is useless if the recursive simplification - -- made no progress; but currently we don't try to optimise that - -- case. After all, we only try hard to reduce at top level, or - -- when inferring types. - - ; let -- extract Id binders for dicts and CoTyVar binders for eqs; - -- see Note [Binders for equalities] - (extra_eq_givens, extra_dict_givens) = partition isEqInst - extra_givens - eq_cotvs = map instToVar extra_eq_givens - dict_ids = map instToId extra_dict_givens - - co = mkWpTyLams tvs - <.> mkWpTyLams eq_cotvs - <.> mkWpLams dict_ids - <.> WpLet (binds `unionBags` bind) - rhs = mkLHsWrap co payload - loc = instLocSpan inst_loc - -- wanted equalities are solved by updating their - -- cotv; we don't generate bindings for them - dict_bndrs = map (L loc . HsVar . instToId) - . filter (not . isEqInst) - $ wanteds - payload = mkBigLHsTup dict_bndrs - - ; traceTc (vcat [text "reduceImplication" <+> ppr name, - ppr simpler_implic_insts, - text "->" <+> ppr rhs]) - ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic - , var_rhs = rhs - , var_inline = notNull dict_ids } - -- See Note [Always inline implication constraints] - )), - simpler_implic_insts) - } - } -reduceImplication _ i = pprPanic "reduceImplication" (ppr i) -\end{code} - -Note [Always inline implication constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose an implication constraint floats out of an INLINE function. -Then although the implication has a single call site, it won't be -inlined. And that is bad because it means that even if there is really -*no* overloading (type signatures specify the exact types) there will -still be dictionary passing in the resulting code. To avert this, -we mark the implication constraints themselves as INLINE, at least when -there is no loss of sharing as a result. - -Note [Freeness and implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's hard to say when an implication constraint can be floated out. Consider - forall {} Eq a => Foo [a] -The (Foo [a]) doesn't mention any of the quantified variables, but it -still might be partially satisfied by the (Eq a). - -There is a useful special case when it *is* easy to partition the -constraints, namely when there are no 'givens'. Consider - forall {a}. () => Bar b -There are no 'givens', and so there is no reason to capture (Bar b). -We can let it float out. But if there is even one constraint we -must be much more careful: - forall {a}. C a b => Bar (m b) -because (C a b) might have a superclass (D b), from which we might -deduce (Bar [b]) when m later gets instantiated to []. Ha! - -Here is an even more exotic example - class C a => D a b -Now consider the constraint - forall b. D Int b => C Int -We can satisfy the (C Int) from the superclass of D, so we don't want -to float the (C Int) out, even though it mentions no type variable in -the constraints! - -One more example: the constraint - class C a => D a b - instance (C a, E c) => E (a,c) - - constraint: forall b. D Int b => E (Int,c) - -You might think that the (D Int b) can't possibly contribute -to solving (E (Int,c)), since the latter mentions 'c'. But -in fact it can, because solving the (E (Int,c)) constraint needs -dictionaries - C Int, E c -and the (C Int) can be satisfied from the superclass of (D Int b). -So we must still not float (E (Int,c)) out. - -To think about: special cases for unary type classes? - -Note [Pruning the givens in an implication constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are about to form the implication constraint - forall tvs. Eq a => Ord b -The (Eq a) cannot contribute to the (Ord b), because it has no access to -the type variable 'b'. So we could filter out the (Eq a) from the givens. -But BE CAREFUL of the examples above in [Freeness and implications]. - -Doing so would be a bit tidier, but all the implication constraints get -simplified away by the optimiser, so it's no great win. So I don't take -advantage of that at the moment. - -If you do, BE CAREFUL of wobbly type variables. - - -%************************************************************************ -%* * - Avails and AvailHow: the pool of evidence -%* * -%************************************************************************ - - -\begin{code} -data Avails = Avails !ImprovementDone !AvailEnv - -type ImprovementDone = Bool -- True <=> some unification has happened - -- so some Irreds might now be reducible - -- keys that are now - -type AvailEnv = FiniteMap Inst AvailHow -data AvailHow - = IsIrred -- Used for irreducible dictionaries, - -- which are going to be lambda bound - - | Given Inst -- Used for dictionaries for which we have a binding - -- e.g. those "given" in a signature - - | Rhs -- Used when there is a RHS - (LHsExpr TcId) -- The RHS - [Inst] -- Insts free in the RHS; we need these too - -instance Outputable Avails where - ppr = pprAvails - -pprAvails :: Avails -> SDoc -pprAvails (Avails imp avails) - = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty) - , nest 2 $ braces $ - vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)] - | (inst,avail) <- Map.toList avails ]] - -instance Outputable AvailHow where - ppr = pprAvail - -------------------------- -pprAvail :: AvailHow -> SDoc -pprAvail IsIrred = text "Irred" -pprAvail (Given x) = text "Given" <+> ppr x -pprAvail (Rhs rhs bs) = sep [text "Rhs" <+> ppr bs, - nest 2 (ppr rhs)] - -------------------------- -extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv -extendAvailEnv env inst avail = Map.insert inst avail env - -findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow -findAvailEnv env wanted = Map.lookup wanted env - -- NB 1: the Ord instance of Inst compares by the class/type info - -- *not* by unique. So - -- d1::C Int == d2::C Int - -emptyAvails :: Avails -emptyAvails = Avails False emptyFM - -findAvail :: Avails -> Inst -> Maybe AvailHow -findAvail (Avails _ avails) wanted = findAvailEnv avails wanted - -elemAvails :: Inst -> Avails -> Bool -elemAvails wanted (Avails _ avails) = wanted `elemFM` avails - -extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails --- Does improvement -extendAvails avails@(Avails imp env) inst avail - = do { imp1 <- tcImproveOne avails inst -- Do any improvement - ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) } - -availsInsts :: Avails -> [Inst] -availsInsts (Avails _ avails) = Map.keys avails - -availsImproved :: Avails -> ImprovementDone -availsImproved (Avails imp _) = imp -\end{code} - -Extracting the bindings from a bunch of Avails. -The bindings do *not* come back sorted in dependency order. -We assume that they'll be wrapped in a big Rec, so that the -dependency analyser can sort them out later - -\begin{code} -type DoneEnv = FiniteMap Inst [Id] --- Tracks which things we have evidence for - -extractResults :: Avails - -> [Inst] -- Wanted - -> TcM (TcDictBinds, -- Bindings - [Inst], -- The insts bound by the bindings - [Inst]) -- Irreducible ones - -- Note [Reducing implication constraints] - -extractResults (Avails _ avails) wanteds - = go emptyBag [] [] emptyFM wanteds - where - go :: TcDictBinds -- Bindings for dicts - -> [Inst] -- Bound by the bindings - -> [Inst] -- Irreds - -> DoneEnv -- Has an entry for each inst in the above three sets - -> [Inst] -- Wanted - -> TcM (TcDictBinds, [Inst], [Inst]) - go binds bound_dicts irreds _ [] - = return (binds, bound_dicts, irreds) - - go binds bound_dicts irreds done (w:ws) - | isEqInst w - = go binds bound_dicts (w:irreds) done' ws - - | Just done_ids@(done_id : rest_done_ids) <- Map.lookup w done - = if w_id `elem` done_ids then - go binds bound_dicts irreds done ws - else - go (add_bind (nlHsVar done_id)) bound_dicts irreds - (Map.insert w (done_id : w_id : rest_done_ids) done) ws - - | otherwise -- Not yet done - = case findAvailEnv avails w of - Nothing -> pprTrace "Urk: extractResults" (ppr w) $ - go binds bound_dicts irreds done ws - - Just IsIrred -> go binds bound_dicts (w:irreds) done' ws - - Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws) - - Just (Given g) -> go binds' bound_dicts irreds (Map.insert w [g_id] done) ws - where - g_id = instToId g - binds' | w_id == g_id = binds - | otherwise = add_bind (nlHsVar g_id) - where - w_id = instToId w - done' = Map.insert w [w_id] done - add_bind rhs = addInstToDictBind binds w rhs -\end{code} - - -Note [No superclasses for Stop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we decide not to reduce an Inst -- the 'WhatToDo' --- we still -add it to avails, so that any other equal Insts will be commoned up -right here. However, we do *not* add superclasses. If we have - df::Floating a - dn::Num a -but a is not bound here, then we *don't* want to derive dn from df -here lest we lose sharing. - -\begin{code} -addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails -addWanted want_scs avails wanted rhs_expr wanteds - = addAvailAndSCs want_scs avails wanted avail - where - avail = Rhs rhs_expr wanteds - -addGiven :: Avails -> Inst -> TcM Avails -addGiven avails given - = addAvailAndSCs want_scs avails given (Given given) - where - want_scs = case instLocOrigin (instLoc given) of - NoScOrigin -> NoSCs - _other -> AddSCs - -- Conditionally add superclasses for 'given' - -- See Note [Recursive instances and superclases] - - -- No ASSERT( not (given `elemAvails` avails) ) because in an - -- instance decl for Ord t we can add both Ord t and Eq t as - -- 'givens', so the assert isn't true -\end{code} - -\begin{code} -addIrred :: WantSCs -> Avails -> Inst -> TcM Avails -addIrred want_scs avails irred = ASSERT2( not (irred `elemAvails` avails), ppr irred $$ ppr avails ) - addAvailAndSCs want_scs avails irred IsIrred - -addAvailAndSCs :: WantSCs -> Avails -> Inst -> AvailHow -> TcM Avails -addAvailAndSCs want_scs avails inst avail - | not (isClassDict inst) = extendAvails avails inst avail - | NoSCs <- want_scs = extendAvails avails inst avail - | otherwise = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) - ; avails' <- extendAvails avails inst avail - ; addSCs is_loop avails' inst } - where - is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys - -- Note: this compares by *type*, not by Unique - deps = findAllDeps (unitVarSet (instToVar inst)) avail - dep_tys = map idType (varSetElems deps) - - findAllDeps :: IdSet -> AvailHow -> IdSet - -- Find all the Insts that this one depends on - -- See Note [SUPERCLASS-LOOP 2] - -- Watch out, though. Since the avails may contain loops - -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far - findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids - findAllDeps so_far _ = so_far - - find_all :: IdSet -> Inst -> IdSet - find_all so_far kid - | isEqInst kid = so_far - | kid_id `elemVarSet` so_far = so_far - | Just avail <- findAvail avails kid = findAllDeps so_far' avail - | otherwise = so_far' - where - so_far' = extendVarSet so_far kid_id -- Add the new kid to so_far - kid_id = instToId kid - -addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails - -- Add all the superclasses of the Inst to Avails - -- The first param says "don't do this because the original thing - -- depends on this one, so you'd build a loop" - -- Invariant: the Inst is already in Avails. - -addSCs is_loop avails dict - = ASSERT( isDict dict ) - do { sc_dicts <- newCtGivens (instLoc dict) sc_theta' - ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) } - where - (clas, tys) = getDictClassTys dict - (tyvars, sc_theta, sc_sels, _) = classBigSig clas - sc_theta' = filter (not . isEqPred) $ - substTheta (zipTopTvSubst tyvars tys) sc_theta - - add_sc avails (sc_dict, sc_sel) - | is_loop (dictPred sc_dict) = return avails -- See Note [SUPERCLASS-LOOP 2] - | is_given sc_dict = return avails - | otherwise = do { avails' <- extendAvails avails sc_dict (Rhs sc_sel_rhs [dict]) - ; addSCs is_loop avails' sc_dict } - where - sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel)) - co_fn = WpApp (instToVar dict) <.> mkWpTyApps tys - - is_given :: Inst -> Bool - is_given sc_dict = case findAvail avails sc_dict of - Just (Given _) -> True -- Given is cheaper than superclass selection - _ -> False - --- From the a set of insts obtain all equalities that (transitively) occur in --- superclass contexts of class constraints (aka the ancestor equalities). --- -ancestorEqualities :: [Inst] -> TcM [Inst] -ancestorEqualities - = mapM mkWantedEqInst -- turn only equality predicates.. - . filter isEqPred -- ..into wanted equality insts - . bagToList - . addAEsToBag emptyBag -- collect the superclass constraints.. - . map dictPred -- ..of all predicates in a bag - . filter isClassDict - where - addAEsToBag :: Bag PredType -> [PredType] -> Bag PredType - addAEsToBag bag [] = bag - addAEsToBag bag (pred:preds) - | pred `elemBag` bag = addAEsToBag bag preds - | isEqPred pred = addAEsToBag bagWithPred preds - | isClassPred pred = addAEsToBag bagWithPred predsWithSCs - | otherwise = addAEsToBag bag preds - where - bagWithPred = bag `snocBag` pred - predsWithSCs = preds ++ substTheta (zipTopTvSubst tyvars tys) sc_theta - -- - (tyvars, sc_theta, _, _) = classBigSig clas - (clas, tys) = getClassPredTys pred -\end{code} - - -%************************************************************************ -%* * -\section{tcSimplifyTop: defaulting} -%* * -%************************************************************************ - - -@tcSimplifyTop@ is called once per module to simplify all the constant -and ambiguous Insts. - -We need to be careful of one case. Suppose we have - - instance Num a => Num (Foo a b) where ... - -and @tcSimplifyTop@ is given a constraint (Num (Foo x y)). Then it'll simplify -to (Num x), and default x to Int. But what about y?? - -It's OK: the final zonking stage should zap y to (), which is fine. - - -\begin{code} -tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds -tcSimplifyTop wanteds - = tc_simplify_top doc False wanteds - where - doc = text "tcSimplifyTop" - -tcSimplifyInteractive wanteds - = tc_simplify_top doc True wanteds - where - doc = text "tcSimplifyInteractive" - --- The TcLclEnv should be valid here, solely to improve --- error message generation for the monomorphism restriction -tc_simplify_top :: SDoc -> Bool -> [Inst] -> TcM (Bag (LHsBind TcId)) -tc_simplify_top doc interactive wanteds - = do { dflags <- getDOpts - ; wanteds <- zonkInsts wanteds - ; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds)) - - ; traceTc (text "tc_simplify_top 0: " <+> ppr wanteds) - ; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds --- ; (irreds1, binds1) <- gentleInferLoop doc1 wanteds - ; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1) - ; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1 - ; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2) - - -- Use the defaulting rules to do extra unification - -- NB: irreds2 are already zonked - ; (irreds3, binds3) <- disambiguate doc3 interactive dflags irreds2 - - -- Deal with implicit parameters - ; let (bad_ips, non_ips) = partition isIPDict irreds3 - (ambigs, others) = partition isTyVarDict non_ips - - ; topIPErrs bad_ips -- Can arise from f :: Int -> Int - -- f x = x + ?y - ; addNoInstanceErrs others - ; addTopAmbigErrs ambigs - - ; return (binds1 `unionBags` binds2 `unionBags` binds3) } - where - doc1 = doc <+> ptext (sLit "(first round)") - doc2 = doc <+> ptext (sLit "(approximate)") - doc3 = doc <+> ptext (sLit "(disambiguate)") -\end{code} - -If a dictionary constrains a type variable which is - * not mentioned in the environment - * and not mentioned in the type of the expression -then it is ambiguous. No further information will arise to instantiate -the type variable; nor will it be generalised and turned into an extra -parameter to a function. - -It is an error for this to occur, except that Haskell provided for -certain rules to be applied in the special case of numeric types. -Specifically, if - * at least one of its classes is a numeric class, and - * all of its classes are numeric or standard -then the type variable can be defaulted to the first type in the -default-type list which is an instance of all the offending classes. - -So here is the function which does the work. It takes the ambiguous -dictionaries and either resolves them (producing bindings) or -complains. It works by splitting the dictionary list by type -variable, and using @disambigOne@ to do the real business. - -@disambigOne@ assumes that its arguments dictionaries constrain all -the same type variable. - -ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to -@()@ instead of @Int@. I reckon this is the Right Thing to do since -the most common use of defaulting is code like: -\begin{verbatim} - _ccall_ foo `seqPrimIO` bar -\end{verbatim} -Since we're not using the result of @foo@, the result if (presumably) -@void@. - -\begin{code} -disambiguate :: SDoc -> Bool -> DynFlags -> [Inst] -> TcM ([Inst], TcDictBinds) - -- Just does unification to fix the default types - -- The Insts are assumed to be pre-zonked -disambiguate doc interactive dflags insts - | null insts - = return (insts, emptyBag) - - | null defaultable_groups - = do { traceTc (text "disambigutate, no defaultable groups" <+> vcat [ppr unaries, ppr insts, ppr bad_tvs, ppr defaultable_groups]) - ; return (insts, emptyBag) } - - | otherwise - = do { -- Figure out what default types to use - default_tys <- getDefaultTys extended_defaulting ovl_strings - - ; traceTc (text "disambiguate1" <+> vcat [ppr insts, ppr unaries, ppr bad_tvs, ppr defaultable_groups]) - ; mapM_ (disambigGroup default_tys) defaultable_groups - - -- disambigGroup does unification, hence try again - ; tryHardCheckLoop doc insts } - - where - extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags - -- See also Trac #1974 - ovl_strings = dopt Opt_OverloadedStrings dflags - - unaries :: [(Inst, Class, TcTyVar)] -- (C tv) constraints - bad_tvs :: TcTyVarSet -- Tyvars mentioned by *other* constraints - (unaries, bad_tvs_s) = partitionWith find_unary insts - bad_tvs = unionVarSets bad_tvs_s - - -- Finds unary type-class constraints - find_unary d@(Dict {tci_pred = ClassP cls [ty]}) - | Just tv <- tcGetTyVar_maybe ty = Left (d,cls,tv) - find_unary inst = Right (tyVarsOfInst inst) - - -- Group by type variable - defaultable_groups :: [[(Inst,Class,TcTyVar)]] - defaultable_groups = filter defaultable_group (equivClasses cmp_tv unaries) - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool - defaultable_group ds@((_,_,tv):_) - = isTyConableTyVar tv -- Note [Avoiding spurious errors] - && not (tv `elemVarSet` bad_tvs) - && defaultable_classes [c | (_,c,_) <- ds] - defaultable_group [] = panic "defaultable_group" - - defaultable_classes clss - | extended_defaulting = any isInteractiveClass clss - | otherwise = all is_std_class clss && (any is_num_class clss) - - -- In interactive mode, or with -XExtendedDefaultRules, - -- we default Show a to Show () to avoid graututious errors on "show []" - isInteractiveClass cls - = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) - - is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - -- is_num_class adds IsString to the standard numeric classes, - -- when -foverloaded-strings is enabled - - is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - -- Similarly is_std_class - ------------------------ -disambigGroup :: [Type] -- The default types - -> [(Inst,Class,TcTyVar)] -- All standard classes of form (C a) - -> TcM () -- Just does unification, to fix the default types - -disambigGroup default_tys dicts - = do { mb_chosen_ty <- try_default default_tys - ; case mb_chosen_ty of - Nothing -> return () - Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) - ; warnDefault dicts chosen_ty } } - where - (_,_,tyvar) = ASSERT(not (null dicts)) head dicts -- Should be non-empty - classes = [c | (_,c,_) <- dicts] - - try_default [] = return Nothing - try_default (default_ty : default_tys) - = tryTcLIE_ (try_default default_tys) $ - do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes] - -- This may fail; then the tryTcLIE_ kicks in - -- Failure here is caused by there being no type in the - -- default list which can satisfy all the ambiguous classes. - -- For example, if Real a is reqd, but the only type in the - -- default list is Int. - - ; return (Just default_ty) -- TOMDO: do something with the coercion - } - - ------------------------ -getDefaultTys :: Bool -> Bool -> TcM [Type] -getDefaultTys extended_deflts ovl_strings - = do { mb_defaults <- getDeclaredDefaultTys - ; case mb_defaults of { - Just tys -> return tys ; -- User-supplied defaults - Nothing -> do - - -- No use-supplied default - -- Use [Integer, Double], plus modifications - { integer_ty <- tcMetaTy integerTyConName - ; checkWiredInTyCon doubleTyCon - ; string_ty <- tcMetaTy stringTyConName - ; return (opt_deflt extended_deflts unitTy - -- Note [Default unitTy] - ++ - [integer_ty,doubleTy] - ++ - opt_deflt ovl_strings string_ty) } } } - where - opt_deflt True ty = [ty] - opt_deflt False _ = [] -\end{code} - -Note [Default unitTy] -~~~~~~~~~~~~~~~~~~~~~ -In interative mode (or with -XExtendedDefaultRules) we add () as the first type we -try when defaulting. This has very little real impact, except in the following case. -Consider: - Text.Printf.printf "hello" -This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't -want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to -default the 'a' to (), rather than to Integer (which is what would otherwise happen; -and then GHCi doesn't attempt to print the (). So in interactive mode, we add -() to the list of defaulting types. See Trac #1200. - -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig - - -%************************************************************************ -%* * -\subsection[simple]{@Simple@ versions} -%* * -%************************************************************************ - -Much simpler versions when there are no bindings to make! - -@tcSimplifyThetas@ simplifies class-type constraints formed by -@deriving@ declarations and when specialising instances. We are -only interested in the simplified bunch of class/type constraints. - -It simplifies to constraints of the form (C a b c) where -a,b,c are type variables. This is required for the context of -instance declarations. - -\begin{code} -tcSimplifyDeriv :: InstOrigin - -> [TyVar] - -> ThetaType -- Wanted - -> TcM ThetaType -- Needed --- Given instance (wanted) => C inst_ty --- Simplify 'wanted' as much as possible - -tcSimplifyDeriv orig tyvars theta - = do { (tvs, _, tenv) <- tcInstTyVars tyvars - -- The main loop may do unification, and that may crash if - -- it doesn't see a TcTyVar, so we have to instantiate. Sigh - -- ToDo: what if two of them do get unified? - ; wanteds <- newCtGivensO orig (substTheta tenv theta) - ; (irreds, _) <- tryHardCheckLoop doc wanteds - - ; let (tv_dicts, others) = partition ok irreds - (tidy_env, tidy_insts) = tidyInsts others - ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts - -- See Note [Exotic derived instance contexts] in TcMType - - ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) - simpl_theta = substTheta rev_env (map dictPred tv_dicts) - -- This reverse-mapping is a pain, but the result - -- should mention the original TyVars not TcTyVars - - ; return simpl_theta } - where - doc = ptext (sLit "deriving classes for a data type") - - ok dict | isDict dict = validDerivPred (dictPred dict) - | otherwise = False - alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"), - ptext (sLit "so you can specify the instance context yourself")] -\end{code} - - -@tcSimplifyDefault@ just checks class-type constraints, essentially; -used with \tr{default} declarations. We are only interested in -whether it worked or not. - -\begin{code} -tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM () - -tcSimplifyDefault theta = do - wanteds <- newCtGivensO DefaultOrigin theta - (irreds, _) <- tryHardCheckLoop doc wanteds - addNoInstanceErrs irreds - if null irreds then - return () - else - traceTc (ptext (sLit "tcSimplifyDefault failing")) >> failM - where - doc = ptext (sLit "default declaration") -\end{code} - - - -%************************************************************************ -%* * -\section{Errors and contexts} -%* * -%************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -\begin{code} -groupErrs :: ([Inst] -> TcM ()) -- Deal with one group - -> [Inst] -- The offending Insts - -> TcM () --- Group together insts with the same origin --- We want to report them together in error messages - -groupErrs _ [] - = return () -groupErrs report_err (inst:insts) - = do { do_one (inst:friends) - ; groupErrs report_err others } - where - -- (It may seem a bit crude to compare the error messages, - -- but it makes sure that we combine just what the user sees, - -- and it avoids need equality on InstLocs.) - (friends, others) = partition is_friend insts - loc_msg = showSDoc (pprInstLoc (instLoc inst)) - is_friend friend = showSDoc (pprInstLoc (instLoc friend)) == loc_msg - do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts) - -- Add location and context information derived from the Insts - --- Add the "arising from..." part to a message about bunch of dicts -addInstLoc :: [Inst] -> Message -> Message -addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts)) - -addTopIPErrs :: [Name] -> [Inst] -> TcM () -addTopIPErrs _ [] - = return () -addTopIPErrs bndrs ips - = do { dflags <- getDOpts - ; addErrTcM (tidy_env, mk_msg dflags tidy_ips) } - where - (tidy_env, tidy_ips) = tidyInsts ips - mk_msg dflags ips - = vcat [sep [ptext (sLit "Implicit parameters escape from"), - nest 2 (ptext (sLit "the monomorphic top-level binding") - <> plural bndrs <+> ptext (sLit "of") - <+> pprBinders bndrs <> colon)], - nest 2 (vcat (map ppr_ip ips)), - monomorphism_fix dflags] - ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip - -topIPErrs :: [Inst] -> TcM () -topIPErrs dicts - = groupErrs report tidy_dicts - where - (tidy_env, tidy_dicts) = tidyInsts dicts - report dicts = addErrTcM (tidy_env, mk_msg dicts) - mk_msg dicts = addInstLoc dicts (ptext (sLit "Unbound implicit parameter") <> - plural tidy_dicts <+> pprDictsTheta tidy_dicts) - -addNoInstanceErrs :: [Inst] -- Wanted (can include implications) - -> TcM () -addNoInstanceErrs insts - = do { let (tidy_env, tidy_insts) = tidyInsts insts - ; reportNoInstances tidy_env Nothing [] tidy_insts } - -reportNoInstances - :: TidyEnv - -> Maybe (InstLoc, [Inst]) -- Context - -- Nothing => top level - -- Just (d,g) => d describes the construct - -- with givens g - -> [SDoc] -- Alternative fix for no-such-instance - -> [Inst] -- What is wanted (can include implications) - -> TcM () - -reportNoInstances tidy_env mb_what alt_fix insts - = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts - -report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM () -report_no_instances tidy_env mb_what alt_fixes insts - = do { inst_envs <- tcGetInstEnvs - ; let (implics, insts1) = partition isImplicInst insts - (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1 - (eqInsts, insts3) = partition isEqInst insts2 - ; traceTc (text "reportNoInstances" <+> vcat - [ppr insts, ppr implics, ppr insts1, ppr insts2]) - ; mapM_ complain_implic implics - ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps - ; groupErrs complain_no_inst insts3 - ; mapM_ (addErrTcM . mk_eq_err) eqInsts - } - where - complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts) - - complain_implic inst -- Recurse! - = reportNoInstances tidy_env - (Just (tci_loc inst, tci_given inst)) - alt_fixes (tci_wanted inst) - - check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc - -- Right msg => overlap message - -- Left inst => no instance - check_overlap inst_envs wanted - | not (isClassDict wanted) = Left wanted - | otherwise - = case lookupInstEnv inst_envs clas tys of - ([], _) -> Left wanted -- No match - -- The case of exactly one match and no unifiers means a - -- successful lookup. That can't happen here, because dicts - -- only end up here if they didn't match in Inst.lookupInst - ([_],[]) - | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted) - res -> Right (mk_overlap_msg wanted res) - where - (clas,tys) = getDictClassTys wanted - - mk_overlap_msg dict (matches, unifiers) - = ASSERT( not (null matches) ) - vcat [ addInstLoc [dict] ((ptext (sLit "Overlapping instances for") - <+> pprPred (dictPred dict))), - sep [ptext (sLit "Matching instances") <> colon, - nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])], - if not (isSingleton matches) - then -- Two or more matches - empty - else -- One match, plus some unifiers - ASSERT( not (null unifiers) ) - parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))), - ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), - ptext (sLit "when compiling the other instance declarations")])] - where - ispecs = [ispec | (ispec, _) <- matches] - - mk_eq_err :: Inst -> (TidyEnv, SDoc) - mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst) - - mk_no_inst_err insts - | null insts = empty - - | Just (loc, givens) <- mb_what, -- Nested (type signatures, instance decls) - not (isEmptyVarSet (tyVarsOfInsts insts)) - = vcat [ addInstLoc insts $ - sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts - , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens] - , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ] - - | otherwise -- Top level - = vcat [ addInstLoc insts $ - ptext (sLit "No instance") <> plural insts - <+> ptext (sLit "for") <+> pprDictsTheta insts - , show_fixes (fixes2 ++ alt_fixes) ] - - where - fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts - <+> ptext (sLit "to the context of"), - nest 2 (ppr (instLocOrigin loc)) ] - -- I'm not sure it helps to add the location - -- nest 2 (ptext (sLit "at") <+> ppr (instLocSpan loc)) ] - - fixes2 | null instance_dicts = [] - | otherwise = [sep [ptext (sLit "add an instance declaration for"), - pprDictsTheta instance_dicts]] - instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)] - -- Insts for which it is worth suggesting an adding an instance declaration - -- Exclude implicit parameters, and tyvar dicts - - show_fixes :: [SDoc] -> SDoc - show_fixes [] = empty - show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), - nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] - -addTopAmbigErrs :: [Inst] -> TcRn () -addTopAmbigErrs dicts --- Divide into groups that share a common set of ambiguous tyvars - = ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened - -- See Note [Avoiding spurious errors] - mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) - where - (tidy_env, tidy_dicts) = tidyInsts dicts - - tvs_of :: Inst -> [TcTyVar] - tvs_of d = varSetElems (tyVarsOfInst d) - cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 - - report :: [(Inst,[TcTyVar])] -> TcM () - report pairs@((inst,tvs) : _) = do -- The pairs share a common set of ambiguous tyvars - (tidy_env, mono_msg) <- mkMonomorphismMsg tidy_env tvs - setSrcSpan (instSpan inst) $ - -- the location of the first one will do for the err message - addErrTcM (tidy_env, msg $$ mono_msg) - where - dicts = map fst pairs - msg = sep [text "Ambiguous type variable" <> plural tvs <+> - pprQuotedList tvs <+> in_msg, - nest 2 (pprDictsInFull dicts)] - in_msg = text "in the constraint" <> plural dicts <> colon - report [] = panic "addTopAmbigErrs" - - -mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message) --- There's an error with these Insts; if they have free type variables --- it's probably caused by the monomorphism restriction. --- Try to identify the offending variable --- ASSUMPTION: the Insts are fully zonked -mkMonomorphismMsg tidy_env inst_tvs - = do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals (mkVarSet inst_tvs) tidy_env - ; return (tidy_env, mk_msg dflags docs) } - where - mk_msg _ _ | any isRuntimeUnk inst_tvs - = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> - (pprWithCommas ppr inst_tvs), - ptext (sLit "Use :print or :force to determine these types")] - mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") - -- This happens in things like - -- f x = show (read "foo") - -- where monomorphism doesn't play any role - mk_msg dflags docs - = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"), - nest 2 (vcat docs), - monomorphism_fix dflags] - -monomorphism_fix :: DynFlags -> SDoc -monomorphism_fix dflags - = ptext (sLit "Probable fix:") <+> vcat - [ptext (sLit "give these definition(s) an explicit type signature"), - if dopt Opt_MonomorphismRestriction dflags - then ptext (sLit "or use -XNoMonomorphismRestriction") - else empty] -- Only suggest adding "-XNoMonomorphismRestriction" - -- if it is not already set! - -warnDefault :: [(Inst, Class, Var)] -> Type -> TcM () -warnDefault ups default_ty = do - warn_flag <- doptM Opt_WarnTypeDefaults - setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) - where - dicts = [d | (d,_,_) <- ups] - - -- Tidy them first - (_, tidy_dicts) = tidyInsts dicts - warn_msg = vcat [ptext (sLit "Defaulting the following constraint(s) to type") <+> - quotes (ppr default_ty), - pprDictsInFull tidy_dicts] - -reduceDepthErr :: Int -> [Inst] -> SDoc -reduceDepthErr n stack - = vcat [ptext (sLit "Context reduction stack overflow; size =") <+> int n, - ptext (sLit "Use -fcontext-stack=N to increase stack size to N"), - nest 4 (pprStack stack)] - -pprStack :: [Inst] -> SDoc -pprStack stack = vcat (map pprInstInFull stack) -\end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index ed8b1c4702..86e98551fb 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -72,6 +72,7 @@ import Pair import Unique import Data.Maybe import BasicTypes +import DynFlags import Panic import FastString import Control.Monad ( when ) @@ -369,14 +370,15 @@ tc_bracket :: ThStage -> HsBracket Name -> TcM TcType tc_bracket outer_stage br@(VarBr _ name) -- Note [Quoting names] = do { thing <- tcLookup name ; case thing of - AGlobal _ -> return () + AGlobal {} -> return () + ATyVar {} -> return () ATcId { tct_level = bind_lvl, tct_id = id } | thTopLevelId id -- C.f TcExpr.checkCrossStageLifting -> keepAliveTc id | otherwise -> do { checkTc (thLevel outer_stage + 1 == bind_lvl) (quotedNameStageErr br) } - _ -> pprPanic "th_bracket" (ppr name) + _ -> pprPanic "th_bracket" (ppr name $$ ppr thing) ; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) } @@ -747,7 +749,7 @@ deprecatedDollar quoter data MetaOps th_syn hs_syn = MT { mt_desc :: String -- Type of beast (expression, type etc) , mt_show :: th_syn -> String -- How to show the th_syn thing - , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn + , mt_cvt :: SrcSpan -> th_syn -> Either MsgDoc hs_syn -- How to convert to hs_syn } @@ -800,7 +802,7 @@ runMetaD = runMetaQ declMetaOps --------------- runMeta :: (Outputable hs_syn) => Bool -- Whether code should be printed in the exception message - -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x + -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr @@ -901,8 +903,8 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where ; let i = getKey u ; return (TH.mkNameU s i) } - qReport True msg = addErr (text msg) - qReport False msg = addReport (text msg) empty + qReport True msg = addErr (text msg) + qReport False msg = addWarn (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM @@ -1105,7 +1107,7 @@ tcLookupTh name else do -- It's imported { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts + ; dflags <- getDynFlags ; case lookupType dflags hpt (eps_PTE eps) name of Just thing -> return (AGlobal thing) Nothing -> do { thing <- tcImportDecl name @@ -1267,7 +1269,7 @@ reifyClass cls ; return (TH.SigD (reifyName op) ty) } ------------------------------ -reifyClassInstance :: Instance -> TcM TH.Dec +reifyClassInstance :: ClsInst -> TcM TH.Dec reifyClassInstance i = do { cxt <- reifyCxt theta ; thtypes <- reifyTypes types @@ -1279,21 +1281,22 @@ reifyClassInstance i ------------------------------ reifyFamilyInstance :: FamInst -> TcM TH.Dec reifyFamilyInstance fi - | isSynTyCon rep_tc - = do { th_tys <- reifyTypes (fi_tys fi) - ; rhs_ty <- reifyType (synTyConType rep_tc) - ; return (TH.TySynInstD fam th_tys rhs_ty) } - - | otherwise - = do { let tvs = tyConTyVars rep_tc - fam = reifyName (fi_fam fi) - ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc) - ; th_tys <- reifyTypes (fi_tys fi) - ; return (if isNewTyCon rep_tc - then TH.NewtypeInstD [] fam th_tys (head cons) [] - else TH.DataInstD [] fam th_tys cons []) } + = case fi_flavor fi of + SynFamilyInst -> + do { th_tys <- reifyTypes (fi_tys fi) + ; rhs_ty <- reifyType (coAxiomRHS rep_ax) + ; return (TH.TySynInstD fam th_tys rhs_ty) } + + DataFamilyInst rep_tc -> + do { let tvs = tyConTyVars rep_tc + fam = reifyName (fi_fam fi) + ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc) + ; th_tys <- reifyTypes (fi_tys fi) + ; return (if isNewTyCon rep_tc + then TH.NewtypeInstD [] fam th_tys (head cons) [] + else TH.DataInstD [] fam th_tys cons []) } where - rep_tc = fi_tycon fi + rep_ax = fi_axiom fi fam = reifyName (fi_fam fi) ------------------------------ diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 5cb871a3a1..18a31b0b93 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,32 +1,25 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcSplice where -import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, +import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import Name ( Name ) +import NameSet ( FreeVars ) +import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcKind ) +import TcType ( TcRhoType, TcKind ) import Annotations ( Annotation, CoreAnnTarget ) import qualified Language.Haskell.TH as TH tcSpliceExpr :: HsSplice Name - -> TcRhoType - -> TcM (HsExpr TcId) + -> TcRhoType + -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> FreeVars - -> TcM (HsType Name, TcKind) + -> TcM (HsType Name, TcKind) tcBracket :: HsBracket Name - -> TcRhoType - -> TcM (LHsExpr TcId) + -> TcRhoType + -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f91ccdf43d..95d7d236a7 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -101,13 +101,10 @@ tcTyAndClassDecls :: ModDetails -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons -- Fails if there are any errors -tcTyAndClassDecls boot_details decls_s - = checkNoErrs $ do -- The code recovers internally, but if anything gave rise to +tcTyAndClassDecls boot_details tyclds_s + = checkNoErrs $ -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - { let tyclds_s = map (filterOut (isFamInstDecl . unLoc)) decls_s - -- Remove family instance decls altogether - -- They are dealt with by TcInstDcls - ; fold_env tyclds_s } -- type check each group in dependency order folding the global env + fold_env tyclds_s -- type check each group in dependency order folding the global env where fold_env :: [TyClGroup Name] -> TcM TcGblEnv fold_env [] = getGblEnv @@ -379,7 +376,7 @@ kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl [] decl -- the empty list signals a toplevel decl kcTyClDecl decl@(TyData {}) - = ASSERT( not . isFamInstDecl $ decl ) -- must not be a family instance + = ASSERT2( not . isFamInstDecl $ decl, ppr decl ) -- must not be a family instance kcTyClDeclBody decl $ \_ -> kcDataDecl decl kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) @@ -558,7 +555,7 @@ tcTyClDecl1 parent _calc_isrec = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "type family:" (ppr tc_name) ; checkFamFlag tc_name - ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing + ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent ; return [ATyCon tycon] } -- "data family" declaration @@ -569,8 +566,8 @@ tcTyClDecl1 parent _calc_isrec ; checkFamFlag tc_name ; extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - ; tycon <- buildAlgTyCon tc_name final_tvs [] - DataFamilyTyCon Recursive True parent Nothing + tycon = buildAlgTyCon tc_name final_tvs [] + DataFamilyTyCon Recursive True parent ; return [ATyCon tycon] } -- "type" synonym declaration @@ -580,7 +577,7 @@ tcTyClDecl1 _parent _calc_isrec tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { rhs_ty' <- tcCheckHsType rhs_ty kind ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - kind NoParentTyCon Nothing + kind NoParentTyCon ; return [ATyCon tycon] } -- "newtype" and "data" @@ -606,7 +603,7 @@ tcTyClDecl1 _parent calc_isrec ; dataDeclChecks tc_name new_or_data stupid_theta cons - ; tycon <- fixM (\ tycon -> do + ; tycon <- fixM $ \ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) ; data_cons <- tcConDecls new_or_data ex_ok tycon (final_tvs, res_ty) cons ; tc_rhs <- @@ -616,9 +613,8 @@ tcTyClDecl1 _parent calc_isrec DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) - ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (not h98_syntax) NoParentTyCon Nothing - }) + ; return (buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs + is_rec (not h98_syntax) NoParentTyCon) } ; return [ATyCon tycon] } tcTyClDecl1 _parent calc_isrec @@ -1365,17 +1361,10 @@ checkValidClass cls -- Check the associated type defaults are well-formed and instantiated -- See Note [Checking consistent instantiation] - ; mapM_ check_at_defs at_stuff - - -- Check that if the class has generic methods, then the - -- class has only one parameter. We can't do generic - -- multi-parameter type classes! - ; checkTc (unary || no_generics) (genericMultiParamErr cls) - } + ; mapM_ check_at_defs at_stuff } where (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - unary = isSingleton (snd (splitKiTyVars tyvars)) -- IA0_NOTE: only count type arguments - no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] + unary = isSingleton (snd (splitKiTyVars tyvars)) -- IA0_NOTE: only count type arguments check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1700,11 +1689,6 @@ noClassTyVarErr clas op ptext (sLit "mentions none of the type variables of the class") <+> ppr clas <+> hsep (map ppr (classTyVars clas))] -genericMultiParamErr :: Class -> SDoc -genericMultiParamErr clas - = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> - ptext (sLit "cannot have generic methods") - recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index d4d2642315..fa59db97da 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -58,7 +58,7 @@ module TcType ( -- Predicates. -- Again, newtypes are opaque eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, - eqKind, + pickyEqType, eqKind, isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, @@ -90,6 +90,7 @@ module TcType ( tidyOpenKind, tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, + tidyTyVarOcc, tidyTopType, tidyKind, tidyCo, tidyCos, @@ -473,7 +474,24 @@ tidyTyVarBndr tidy_env@(occ_env, subst) tyvar tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv -- ^ Add the free 'TyVar's to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) +tidyFreeTyVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyVars (trimmed_occ_env, var_env) tv_list) + + where + tv_list = varSetElems tyvars + + trimmed_occ_env = foldr mk_occ_env emptyOccEnv tv_list + -- The idea here is that we restrict the new TidyEnv to the + -- _free_ vars of the type, so that we don't gratuitously rename + -- the _bound_ variables of the type + + mk_occ_env :: TyVar -> TidyOccEnv -> TidyOccEnv + mk_occ_env tv env + = case lookupOccEnv full_occ_env occ of + Just n -> extendOccEnv env occ n + Nothing -> env + where + occ = getOccName tv --------------- tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) @@ -490,26 +508,18 @@ tidyOpenTyVar env@(_, subst) tyvar Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder --------------- -tidyType :: TidyEnv -> Type -> Type -tidyType env@(_, subst) ty - = go ty +tidyTyVarOcc :: TidyEnv -> TyVar -> Type +tidyTyVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> expand tv + Just tv' -> expand tv' where - go (TyVarTy tv) = case lookupVarEnv subst tv of - Nothing -> expand tv - Just tv' -> expand tv' - go (TyConApp tycon tys) = let args = map go tys - in args `seqList` TyConApp tycon args - go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) - go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) - go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) - where - (envp, tvp) = tidyTyVarBndr env tv - -- Expand FlatSkols, the skolems introduced by flattening process -- We don't want to show them in type error messages expand tv | isTcTyVar tv , FlatSkol ty <- tcTyVarDetails tv - = go ty + = WARN( True, text "I DON'T THINK THIS SHOULD EVER HAPPEN" <+> ppr tv <+> ppr ty ) + tidyType env ty | otherwise = TyVarTy tv @@ -518,6 +528,17 @@ tidyTypes :: TidyEnv -> [Type] -> [Type] tidyTypes env tys = map (tidyType env) tys --------------- +tidyType :: TidyEnv -> Type -> Type +tidyType env (TyVarTy tv) = tidyTyVarOcc env tv +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) + where + (envp, tvp) = tidyTyVarBndr env tv + +--------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) @@ -1000,7 +1021,25 @@ tcInstHeadTyAppAllTyVars ty get_tv _ = Nothing \end{code} - +\begin{code} +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +pickyEqType ty1 ty2 + = go init_env ty1 ty2 + where + init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go (rnBndr2 env tv1 tv2) t1 t2 + go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 + go _ _ _ = False + + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False +\end{code} %************************************************************************ %* * diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 23de50af56..a6e1db183c 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -31,7 +31,7 @@ module TcUnify ( matchExpectedFunTys, matchExpectedFunKind, wrapFunResCoercion, - failWithMisMatch, + wrapEqCtxt, -------------------------------- -- Errors @@ -148,11 +148,6 @@ matchExpectedFunTys herald arity orig_ty = do { (co, tys, ty_r) <- go (n_req-1) res_ty ; return (mkTcFunCo (mkTcReflCo arg_ty) co, arg_ty:tys, ty_r) } - go _ (TyConApp tc _) -- A common case - | not (isSynFamilyTyCon tc) - = do { (env,msg) <- mk_ctxt emptyTidyEnv - ; failWithTcM (env,msg) } - go n_req ty@(TyVarTy tv) | ASSERT( isTcTyVar tv) isMetaTyVar tv = do { cts <- readMetaTyVar tv @@ -172,7 +167,7 @@ matchExpectedFunTys herald arity orig_ty ; return (co, arg_tys, res_ty) } ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, Message) + mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) mk_ctxt env = do { orig_ty1 <- zonkTcType orig_ty ; let (env', orig_ty2) = tidyOpenType env orig_ty1 (args, _) = tcSplitFunTys orig_ty2 @@ -449,7 +444,7 @@ newImplication skol_info skol_tvs given thing_inside ; loc <- getCtLoc skol_info ; emitImplication $ Implic { ic_untch = untch , ic_env = lcl_env - , ic_skols = mkVarSet skol_tvs + , ic_skols = skol_tvs , ic_given = given , ic_wanted = wanted , ic_insol = insolubleWC wanted @@ -536,11 +531,11 @@ uType, uType_np, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer (item : origin) ty1 ty2 - = wrapEqCtxt origin $ +uType_defer items ty1 ty2 + = ASSERT( not (null items) ) do { eqv <- newEq ty1 ty2 - ; loc <- getCtLoc (TypeEqOrigin item) - ; emitFlat (mkEvVarX eqv loc) + ; loc <- getCtLoc (TypeEqOrigin (last items)) + ; emitFlat (mkNonCanonical eqv (Wanted loc)) -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because @@ -549,11 +544,9 @@ uType_defer (item : origin) ty1 ty2 { ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, - ppr ty2, ppr origin, doc]) + ppr ty2, ppr items, doc]) } ; return (mkTcCoVarCo eqv) } -uType_defer [] _ _ - = panic "uType_defer" -------------- -- Push a new item on the origin stack (the most common case) @@ -572,9 +565,6 @@ uType_np origin orig_ty1 orig_ty2 else traceTc "u_tys yields coercion:" (ppr co) ; return co } where - bale_out :: [EqOrigin] -> TcM a - bale_out origin = failWithMisMatch origin - go :: TcType -> TcType -> TcM TcCoercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -583,8 +573,16 @@ uType_np origin orig_ty1 orig_ty2 -- Note that we pass in *original* (before synonym expansion), -- so that type variables tend to get filled in with -- the most informative version of the type - go (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2 - go ty1 (TyVarTy tyvar2) = uVar origin IsSwapped tyvar2 ty1 + go (TyVarTy tv1) ty2 + = do { lookup_res <- lookupTcTyVar tv1 + ; case lookup_res of + Filled ty1 -> go ty1 ty2 + Unfilled ds1 -> uUnfilledVar origin NotSwapped tv1 ds1 ty2 } + go ty1 (TyVarTy tv2) + = do { lookup_res <- lookupTcTyVar tv2 + ; case lookup_res of + Filled ty2 -> go ty1 ty2 + Unfilled ds2 -> uUnfilledVar origin IsSwapped tv2 ds2 ty1 } -- See Note [Expanding synonyms during unification] -- @@ -612,62 +610,61 @@ uType_np origin orig_ty1 orig_ty2 | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 -- See Note [TyCon app] - = do { cos <- uList origin uType tys1 tys2 + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, length tys1 == length tys2 + = do { cos <- zipWithM (uType origin) tys1 tys2 ; return $ mkTcTyConAppCo tc1 cos } -- See Note [Care with type applications] - go (AppTy s1 t1) ty2 - | Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go (AppTy s1 t1) (AppTy s2 t2) + = go_app s1 t1 s2 t2 - go ty1 (AppTy s2 t2) - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - = do { co_s <- uType_np origin s1 s2 - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + go (AppTy s1 t1) (TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = ASSERT( isDecomposableTyCon tc2 ) + go_app s1 t1 (TyConApp tc2 ts2') t2' + + go (TyConApp tc1 ts1) (AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = ASSERT( isDecomposableTyCon tc1 ) + go_app (TyConApp tc1 ts1') t1' s2 t2 go ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 = unifySigmaTy origin ty1 ty2 -- Anything else fails - go _ _ = bale_out origin + go ty1 ty2 = uType_defer origin ty1 ty2 -- failWithMisMatch origin + + ------------------ + go_app s1 t1 s2 t2 + = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] + ; co_t <- uType origin t1 t2 + ; return $ mkTcAppCo co_s co_t } unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM TcCoercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 - ; unless (equalLength tvs1 tvs2) (failWithMisMatch origin) - ; skol_tvs <- tcInstSkolTyVars tvs1 + + ; defer_or_continue (not (equalLength tvs1 tvs2)) $ do { + skol_tvs <- tcInstSkolTyVars tvs1 -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs in_scope = mkInScopeSet (mkVarSet skol_tvs) phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 - skol_info = UnifyForAllSkol ty1 + skol_info = UnifyForAllSkol skol_tvs phi1 ; (ev_binds, co) <- checkConstraints skol_info skol_tvs [] $ uType origin phi1 phi2 - ; return (foldr mkTcForAllCo (TcLetCo ev_binds co) skol_tvs) } - ---------------- -uList :: [EqOrigin] - -> ([EqOrigin] -> a -> a -> TcM b) - -> [a] -> [a] -> TcM [b] --- Unify corresponding elements of two lists of types, which --- should be of equal length. We charge down the list explicitly so that --- we can complain if their lengths differ. -uList _ _ [] [] = return [] -uList origin unify (ty1:tys1) (ty2:tys2) = do { x <- unify origin ty1 ty2; - ; xs <- uList origin unify tys1 tys2 - ; return (x:xs) } -uList origin _ _ _ = failWithMisMatch origin - -- See Note [Mismatched type lists and application decomposition] - + ; return (foldr mkTcForAllCo (TcLetCo ev_binds co) skol_tvs) } } + where + defer_or_continue True _ = uType_defer origin ty1 ty2 + defer_or_continue False m = m \end{code} Note [Care with type applications] @@ -679,7 +676,7 @@ so if one type is an App the other one jolly well better be too Note [Unifying AppTy] ~~~~~~~~~~~~~~~~~~~~~ -Considerm unifying (m Int) ~ (IO Int) where m is a unification variable +Consider unifying (m Int) ~ (IO Int) where m is a unification variable that is now bound to (say) (Bool ->). Then we want to report "Can't unify (Bool -> Int) with (IO Int) and not @@ -687,16 +684,6 @@ and not That is why we use the "_np" variant of uType, which does not alter the error message. -Note [TyCon app] -~~~~~~~~~~~~~~~~ -When we find two TyConApps, the argument lists are guaranteed equal -length. Reason: intially the kinds of the two types to be unified is -the same. The only way it can become not the same is when unifying two -AppTys (f1 a1)~(f2 a2). In that case there can't be a TyConApp in -the f1,f2 (because it'd absorb the app). If we unify f1~f2 first, -which we do, that ensures that f1,f2 have the same kind; and that -means a1,a2 have the same kind. And now the argument repeats. - Note [Mismatched type lists and application decomposition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we find two TyConApps, you might think that the argument lists @@ -765,20 +752,6 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM TcCoercion -uVar origin swapped tv1 ty2 - = do { traceTc "uVar" (vcat [ ppr origin - , ppr swapped - , ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , nest 2 (ptext (sLit " ~ ")) - , ppr ty2 <+> dcolon <+> ppr (typeKind ty2)]) - ; details <- lookupTcTyVar tv1 - ; case details of - Filled ty1 -> unSwap swapped (uType_np origin) ty1 ty2 - Unfilled details1 -> uUnfilledVar origin swapped tv1 details1 ty2 - } - ----------------- uUnfilledVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 @@ -923,15 +896,11 @@ checkTauTvUpdate tv ty Note [Avoid deferring] ~~~~~~~~~~~~~~~~~~~~~~ -We try to avoid creating deferred constraints for two reasons. - * First, efficiency. - * Second, currently we can only defer some constraints - under a forall. See unifySigmaTy. -So expanding synonyms here is a good thing to do. Example (Trac #4917) +We try to avoid creating deferred constraints only for efficiency. +Example (Trac #4917) a ~ Const a b where type Const a b = a. We can solve this immediately, even when -'a' is a skolem, just by expanding the synonym; and we should do so - in case this unification happens inside unifySigmaTy (sigh). +'a' is a skolem, just by expanding the synonym. Note [Type synonyms and the occur check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1041,29 +1010,6 @@ wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a -- comes from the outermost item wrapEqCtxt [] thing_inside = thing_inside wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside - ---------------- -failWithMisMatch :: [EqOrigin] -> TcM a --- Generate the message when two types fail to match, --- going to some trouble to make it helpful. --- We take the failing types from the top of the origin stack --- rather than reporting the particular ones we are looking --- at right now -failWithMisMatch (item:origin) - = wrapEqCtxt origin $ - do { ty_act <- zonkTcType (uo_actual item) - ; ty_exp <- zonkTcType (uo_expected item) - ; env0 <- tcInitTidyEnv - ; let (env1, pp_exp) = tidyOpenType env0 ty_exp - (env2, pp_act) = tidyOpenType env1 ty_act - ; failWithTcM (env2, misMatchMsg pp_act pp_exp) } -failWithMisMatch [] - = panic "failWithMisMatch" - -misMatchMsg :: TcType -> TcType -> SDoc -misMatchMsg ty_act ty_exp - = sep [ ptext (sLit "Couldn't match expected type") <+> quotes (ppr ty_exp) - , nest 12 $ ptext (sLit "with actual type") <+> quotes (ppr ty_act)] \end{code} @@ -1377,7 +1323,7 @@ These two context are used with checkSigTyVars \begin{code} sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType - -> TidyEnv -> TcM (TidyEnv, Message) + -> TidyEnv -> TcM (TidyEnv, MsgDoc) sigCtxt id sig_tvs sig_theta sig_tau tidy_env = do actual_tau <- zonkTcType sig_tau let diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index f53b658f40..4d07229963 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -1,11 +1,4 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TcUnify where import TcType ( TcTauType, TcKind, Type, Kind ) import VarEnv ( TidyEnv ) diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index cda98de45e..992fde7920 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -105,7 +105,7 @@ type ClassATItem = (TyCon, [ATDefault]) -- Each associated type default template is a triple of: data ATDefault = ATD { -- TyVars of the RHS and family arguments - -- (including the class TVs) + -- (including, but perhaps more than, the class TVs) atDefaultTys :: [TyVar], -- The instantiated family arguments atDefaultPats :: [Type], diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 840365ef78..735b3e3e3b 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -24,13 +24,17 @@ module Coercion ( isReflCo_maybe, mkCoercionType, + -- ** Functions over coercion axioms + coAxiomSplitLHS, + -- ** Constructing coercions mkReflCo, mkCoVarCo, - mkAxInstCo, mkPiCo, mkPiCos, + mkAxInstCo, mkAxInstRHS, + mkPiCo, mkPiCos, mkSymCo, mkTransCo, mkNthCo, mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, mkForAllCo, mkUnsafeCo, - mkNewTypeCo, mkFamInstCo, + mkNewTypeCo, -- ** Decomposition splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo, @@ -82,7 +86,7 @@ import TyCon import Var import VarEnv import VarSet -import Maybes ( orElse ) +import Maybes ( orElse ) import Name ( Name, NamedThing(..), nameUnique ) import OccName ( parenSymOcc ) import Util @@ -277,6 +281,23 @@ Now (Nth 0 g) will optimise to Refl, but perhaps not instantly. %************************************************************************ +%* * +\subsection{Coercion axioms} +%* * +%************************************************************************ +These functions are not in TyCon because they need knowledge about +the type representation (from TypeRep) + +\begin{code} +-- If `ax :: F a ~ b`, and `F` is a family instance, returns (F, [a]) +coAxiomSplitLHS :: CoAxiom -> (TyCon, [Type]) +coAxiomSplitLHS ax + = case splitTyConApp_maybe (coAxiomLHS ax) of + Just (tc,tys) -> (tc,tys) + Nothing -> pprPanic "coAxiomSplitLHS" (ppr ax) +\end{code} + +%************************************************************************ %* * \subsection{Coercion variables} %* * @@ -297,8 +318,9 @@ isCoVar v = isCoVarType (varType v) isCoVarType :: Type -> Bool isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality - | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey - | otherwise = False + = case splitTyConApp_maybe ty of + Just (tc,tys) -> tc `hasKey` eqPrimTyConKey && tys `lengthAtLeast` 2 + Nothing -> False \end{code} @@ -435,8 +457,9 @@ pprCoAxiom ax -- -- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] decomposeCo :: Arity -> Coercion -> [Coercion] -decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ] - -- Remember, Nth is zero-indexed +decomposeCo arity co + = [mkNthCo n co | n <- [0..(arity-1)] ] + -- Remember, Nth is zero-indexed -- | Attempts to obtain the type variable underlying a 'Coercion' getCoVar_maybe :: Coercion -> Maybe CoVar @@ -511,6 +534,8 @@ mkReflCo :: Type -> Coercion mkReflCo = Refl mkAxInstCo :: CoAxiom -> [Type] -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires mkAxInstCo ax tys | arity == n_tys = AxiomInstCo ax rtys | otherwise = ASSERT( arity < n_tys ) @@ -521,6 +546,19 @@ mkAxInstCo ax tys arity = coAxiomArity ax rtys = map Refl tys +mkAxInstRHS :: CoAxiom -> [Type] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax tys = snd (coercionKind (mkAxInstCo ax tys)) +mkAxInstRHS ax tys + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys rhs' tys2 + where + tvs = coAxiomTyVars ax + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 (coAxiomRHS ax) + -- | Apply a 'Coercion' to another 'Coercion'. mkAppCo :: Coercion -> Coercion -> Coercion mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2) @@ -579,8 +617,17 @@ mkTransCo co (Refl _) = co mkTransCo co1 co2 = TransCo co1 co2 mkNthCo :: Int -> Coercion -> Coercion -mkNthCo n (Refl ty) = Refl (tyConAppArgN n ty) -mkNthCo n co = NthCo n co +mkNthCo n (Refl ty) = ASSERT( ok_tc_app ty n ) + Refl (tyConAppArgN n ty) +mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) + NthCo n co + where + Pair _ty1 _ty2 = coercionKind co + +ok_tc_app :: Type -> Int -> Bool +ok_tc_app ty n = case splitTyConApp_maybe ty of + Just (_, tys) -> tys `lengthExceeds` n + Nothing -> False -- | Instantiates a 'Coercion' with a 'Type' argument. mkInstCo :: Coercion -> Type -> Coercion @@ -611,28 +658,12 @@ mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2 -- the free variables a subset of those 'TyVar's. mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom mkNewTypeCo name tycon tvs rhs_ty - = CoAxiom { co_ax_unique = nameUnique name - , co_ax_name = name - , co_ax_tvs = tvs - , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs) - , co_ax_rhs = rhs_ty } - --- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type --- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is --- the coercion constructor built here, @F@ the family tycon and @R@ the (derived) --- representation tycon. -mkFamInstCo :: Name -- ^ Unique name for the coercion tycon - -> [TyVar] -- ^ Type parameters of the coercion (@tvs@) - -> TyCon -- ^ Family tycon (@F@) - -> [Type] -- ^ Type instance (@ts@) - -> TyCon -- ^ Representation tycon (@R@) - -> CoAxiom -- ^ Coercion constructor (@Co@) -mkFamInstCo name tvs family inst_tys rep_tycon - = CoAxiom { co_ax_unique = nameUnique name - , co_ax_name = name - , co_ax_tvs = tvs - , co_ax_lhs = mkTyConApp family inst_tys - , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) } + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs) + , co_ax_rhs = rhs_ty } mkPiCos :: [Var] -> Coercion -> Coercion mkPiCos vs co = foldr mkPiCo co vs diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 236185168b..2952912b39 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -13,13 +13,15 @@ FamInstEnv: Type checked family instance declarations -- for details module FamInstEnv ( - FamInst(..), famInstTyCon, famInstTyVars, + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyVars, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + famInstLHS, pprFamInst, pprFamInstHdr, pprFamInsts, - famInstHead, mkLocalFamInst, mkImportedFamInst, + mkSynFamInst, mkDataFamInst, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, overwriteFamInstEnv, extendFamInstEnvList, - famInstEnvElts, familyInstances, + extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, + identicalFamInst, famInstEnvElts, familyInstances, lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts', @@ -36,6 +38,7 @@ import TypeRep import TyCon import Coercion import VarSet +import VarEnv import Name import UniqFM import Outputable @@ -51,30 +54,76 @@ import FastString %* * %************************************************************************ +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family + + \begin{code} -data FamInst - = FamInst { fi_fam :: Name -- Family name - -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of - -- Just (tc, tys) -> tc +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom -- The new coercion axiom introduced + -- by this family instance + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + , fi_fam :: Name -- Family name + -- INVARIANT: fi_fam = name of fi_fam_tc -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in InstEnv , fi_tcs :: [Maybe Name] -- Top of type args -- INVARIANT: fi_tcs = roughMatchTcs fi_tys -- Used for "proper matching"; ditto - , fi_tvs :: TyVarSet -- Template tyvars for full match - , fi_tys :: [Type] -- Full arg types - -- INVARIANT: fi_tvs = tyConTyVars fi_tycon - -- fi_tys = case tyConFamInst_maybe fi_tycon of - -- Just (_, tys) -> tys + , fi_tvs :: TyVarSet -- Template tyvars for full match + , fi_fam_tc :: TyCon -- Family tycon + , fi_tys :: [Type] -- and its arg types + -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom + -- (fi_fam_tc, fi_tys) = coAxiomSplitLHS fi_axiom + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon +\end{code} - , fi_tycon :: TyCon -- Representation tycon - } --- Obtain the representation tycon of a family instance. --- -famInstTyCon :: FamInst -> TyCon -famInstTyCon = fi_tycon +\begin{code} +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom +famInstAxiom = fi_axiom + +famInstLHS :: FamInst -> (TyCon, [Type]) +famInstLHS (FamInst { fi_fam_tc = tc, fi_tys = tys }) = (tc, tys) + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) famInstTyVars :: FamInst -> TyVarSet famInstTyVars = fi_tvs @@ -82,7 +131,7 @@ famInstTyVars = fi_tvs \begin{code} instance NamedThing FamInst where - getName = getName . fi_tycon + getName = coAxiomName . fi_axiom instance Outputable FamInst where ppr = pprFamInst @@ -91,18 +140,17 @@ instance Outputable FamInst where pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) - 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax) + 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax) + , ifPprDebug (ptext (sLit "RHS:") <+> ppr (coAxiomRHS ax)) , ptext (sLit "--") <+> pprDefinedAt (getName famInst)]) where - pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of - Just ax -> ppr ax - Nothing -> ptext (sLit "<not there!>") + ax = fi_axiom famInst pprFamInstHdr :: FamInst -> SDoc -pprFamInstHdr (FamInst {fi_tycon = rep_tc}) +pprFamInstHdr (FamInst {fi_axiom = axiom, fi_flavor = flavor}) = pprTyConSort <+> pp_instance <+> pprHead where - Just (fam_tc, tys) = tyConFamInst_maybe rep_tc + (fam_tc, tys) = coAxiomSplitLHS axiom -- For *associated* types, say "type T Int = blah" -- For *top level* type instances, say "type instance T Int = blah" @@ -111,55 +159,100 @@ pprFamInstHdr (FamInst {fi_tycon = rep_tc}) | otherwise = ptext (sLit "instance") pprHead = pprTypeApp fam_tc tys - pprTyConSort | isDataTyCon rep_tc = ptext (sLit "data") - | isNewTyCon rep_tc = ptext (sLit "newtype") - | isSynTyCon rep_tc = ptext (sLit "type") - | isAbstractTyCon rep_tc = ptext (sLit "data") - | otherwise = panic "FamInstEnv.pprFamInstHdr" + pprTyConSort = case flavor of + SynFamilyInst -> ptext (sLit "type") + DataFamilyInst tycon + | isDataTyCon tycon -> ptext (sLit "data") + | isNewTyCon tycon -> ptext (sLit "newtype") + | isAbstractTyCon tycon -> ptext (sLit "data") + | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) -famInstHead :: FamInst -> ([TyVar], TyCon, [Type]) -famInstHead (FamInst {fi_tycon = tycon}) - = case tyConFamInst_maybe tycon of - Nothing -> panic "FamInstEnv.famInstHead" - Just (fam, tys) -> (tyConTyVars tycon, fam, tys) - --- Make a family instance representation from a tycon. This is used for local --- instances, where we can safely pull on the tycon. --- -mkLocalFamInst :: TyCon -> FamInst -mkLocalFamInst tycon - = case tyConFamInst_maybe tycon of - Nothing -> panic "FamInstEnv.mkLocalFamInst" - Just (fam, tys) -> - FamInst { - fi_fam = tyConName fam, - fi_tcs = roughMatchTcs tys, - fi_tvs = mkVarSet . tyConTyVars $ tycon, - fi_tys = tys, - fi_tycon = tycon - } +-- | Create a coercion identifying a @type@ family instance. +-- It has the form @Co tvs :: F ts ~ R@, where @Co@ is +-- the coercion constructor built here, @F@ the family tycon and @R@ the +-- right-hand side of the type family instance. +mkSynFamInst :: Name -- ^ Unique name for the coercion tycon + -> [TyVar] -- ^ Type parameters of the coercion (@tvs@) + -> TyCon -- ^ Family tycon (@F@) + -> [Type] -- ^ Type instance (@ts@) + -> Type -- ^ Representation tycon (@R@) + -> FamInst +mkSynFamInst name tvs fam_tc inst_tys rep_ty + = FamInst { fi_fam = tyConName fam_tc, + fi_fam_tc = fam_tc, + fi_tcs = roughMatchTcs inst_tys, + fi_tvs = mkVarSet tvs, + fi_tys = inst_tys, + fi_flavor = SynFamilyInst, + fi_axiom = axiom } + where + axiom = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = False + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp fam_tc inst_tys + , co_ax_rhs = rep_ty } + +-- | Create a coercion identifying a @data@ or @newtype@ representation type +-- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, +-- where @Co@ is the coercion constructor built here, @F@ the family tycon +-- and @R@ the (derived) representation tycon. +mkDataFamInst :: Name -- ^ Unique name for the coercion tycon + -> [TyVar] -- ^ Type parameters of the coercion (@tvs@) + -> TyCon -- ^ Family tycon (@F@) + -> [Type] -- ^ Type instance (@ts@) + -> TyCon -- ^ Representation tycon (@R@) + -> FamInst +mkDataFamInst name tvs fam_tc inst_tys rep_tc + = FamInst { fi_fam = tyConName fam_tc, + fi_fam_tc = fam_tc, + fi_tcs = roughMatchTcs inst_tys, + fi_tvs = mkVarSet tvs, + fi_tys = inst_tys, + fi_flavor = DataFamilyInst rep_tc, + fi_axiom = axiom } + where + axiom = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = False + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp fam_tc inst_tys + , co_ax_rhs = mkTyConApp rep_tc (mkTyVarTys tvs) } -- Make a family instance representation from the information found in an --- unterface file. In particular, we get the rough match info from the iface +-- interface file. In particular, we get the rough match info from the iface -- (instead of computing it here). --- -mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst -mkImportedFamInst fam mb_tcs tycon +mkImportedFamInst :: Name -- Name of the family + -> [Maybe Name] -- Rough match info + -> CoAxiom -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom = FamInst { - fi_fam = fam, - fi_tcs = mb_tcs, - fi_tvs = mkVarSet . tyConTyVars $ tycon, - fi_tys = case tyConFamInst_maybe tycon of - Nothing -> panic "FamInstEnv.mkImportedFamInst" - Just (_, tys) -> tys, - fi_tycon = tycon - } + fi_fam = fam, + fi_fam_tc = fam_tc, + fi_tcs = mb_tcs, + fi_tvs = mkVarSet . coAxiomTyVars $ axiom, + fi_tys = tys, + fi_axiom = axiom, + fi_flavor = flavor } + where + (fam_tc, tys) = coAxiomSplitLHS axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe (coAxiomRHS axiom) of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst \end{code} + %************************************************************************ %* * FamInstEnv @@ -233,42 +326,26 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) (ins_tyvar || tyvar) ins_tyvar = not (any isJust mb_tcs) -overwriteFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -overwriteFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) - = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar) +deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) + = adjustUFM adjust inst_env fam_nm + where + adjust :: FamilyInstEnv -> FamilyInstEnv + adjust (FamIE items tyvars) + = FamIE (filterOut (identicalFamInst fam_inst) items) tyvars + +identicalFamInst :: FamInst -> FamInst -> Bool +-- Same LHS, *and* the instance is defined in the same module +-- Used for overriding in GHCi +identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) + = nameModule (coAxiomName ax1) == nameModule (coAxiomName ax2) + && eqTypeX rn_env (coAxiomLHS ax1) (coAxiomLHS ax2) where - add (FamIE items tyvar) _ = FamIE (replaceFInst items) - (ins_tyvar || tyvar) - ins_tyvar = not (any isJust mb_tcs) - match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys - - inst_tycon = famInstTyCon ins_item - (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" - (tyConFamInst_maybe inst_tycon) - arity = tyConArity fam - n_tys = length tys - match_tys - | arity > n_tys = take arity tys - | otherwise = tys - rough_tcs = roughMatchTcs match_tys - - replaceFInst [] = [ins_item] - replaceFInst (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, - fi_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = item : replaceFInst rest - - -- Proper check - | Just _ <- match item tpl_tvs tpl_tys match_tys - = ins_item : rest - - -- No match => try next - | otherwise - = item : replaceFInst rest - - - + tvs1 = coAxiomTyVars ax1 + tvs2 = coAxiomTyVars ax2 + rn_env = ASSERT( equalLength tvs1 tvs2 ) + rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2 + \end{code} %************************************************************************ @@ -326,11 +403,10 @@ lookupFamInstEnvConflicts lookupFamInstEnvConflicts envs fam_inst skol_tvs = lookup_fam_inst_env my_unify False envs fam tys1 where - inst_tycon = famInstTyCon fam_inst - (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" - (tyConFamInst_maybe inst_tycon) - skol_tys = mkTyVarTys skol_tvs - tys1 = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys + inst_axiom = famInstAxiom fam_inst + (fam, tys) = famInstLHS fam_inst + skol_tys = mkTyVarTys skol_tvs + tys1 = substTys (zipTopTvSubst (coAxiomTyVars inst_axiom) skol_tys) tys -- In example above, fam tys' = F [b] my_unify old_fam_inst tpl_tvs tpl_tys match_tys @@ -348,10 +424,10 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs | isAlgTyCon fam = True | otherwise = not (old_rhs `eqType` new_rhs) where - old_tycon = famInstTyCon old_fam_inst - old_tvs = tyConTyVars old_tycon - old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs) - new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs) + old_axiom = famInstAxiom old_fam_inst + old_tvs = coAxiomTyVars old_axiom + old_rhs = mkAxInstRHS old_axiom (substTyVars subst old_tvs) + new_rhs = mkAxInstRHS inst_axiom (substTyVars subst skol_tvs) -- This variant is called when we want to check if the conflict is only in the -- home environment (see FamInst.addLocalFamInst) @@ -436,14 +512,14 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys -------------- find [] = [] find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, - fi_tys = tpl_tys, fi_tycon = tycon }) : rest) + fi_tys = tpl_tys, fi_axiom = axiom }) : rest) -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs = find rest -- Proper check | Just subst <- match_fun item tpl_tvs tpl_tys match_tys - = (item, add_extra_tys $ substTyVars subst (tyConTyVars tycon)) : find rest + = (item, add_extra_tys $ substTyVars subst (coAxiomTyVars axiom)) : find rest -- No match => try next | otherwise @@ -547,11 +623,11 @@ normaliseTcApp env tc tys , tyConArity tc <= length tys -- Unsaturated data families are possible , [(fam_inst, inst_tys)] <- lookupFamInstEnv env tc ntys = let -- A matching family instance exists - rep_tc = famInstTyCon fam_inst - co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc) - co = mkAxInstCo co_tycon inst_tys + ax = famInstAxiom fam_inst + co = mkAxInstCo ax inst_tys + rhs = mkAxInstRHS ax inst_tys first_coi = mkTransCo tycon_coi co - (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc inst_tys) + (rest_coi,nty) = normaliseType env rhs fix_coi = mkTransCo first_coi rest_coi in (fix_coi, nty) diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index 70eabb441a..8a158139cc 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -324,7 +324,7 @@ improveFromInstEnv inst_env pred@(ty, _) -- Remember that instanceCantMatch treats both argumnents -- symmetrically, so it's ok to trim the rough_tcs, -- rather than trimming each inst_tcs in turn - , ispec@(Instance { is_tvs = qtvs, is_tys = tys_inst, + , ispec@(ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = inst_tcs }) <- instances , not (instanceCantMatch inst_tcs trimmed_tcs) , let p_inst = (mkClassPred cls tys_inst, @@ -504,8 +504,8 @@ if s1 matches \begin{code} -checkFunDeps :: (InstEnv, InstEnv) -> Instance - -> Maybe [Instance] -- Nothing <=> ok +checkFunDeps :: (InstEnv, InstEnv) -> ClsInst + -> Maybe [ClsInst] -- Nothing <=> ok -- Just dfs <=> conflict with dfs -- Check wheher adding DFunId would break functional-dependency constraints -- Used only for instance decls defined in the module being compiled @@ -518,14 +518,14 @@ checkFunDeps inst_envs ispec cls_inst_env = classInstances inst_envs clas bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys -badFunDeps :: [Instance] -> Class +badFunDeps :: [ClsInst] -> Class -> TyVarSet -> [Type] -- Proposed new instance type - -> [Instance] + -> [ClsInst] badFunDeps cls_insts clas ins_tv_set ins_tys = nubBy eq_inst $ [ ispec | fd <- fds, -- fds is often empty, so do this first! let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, - ispec@(Instance { is_tcs = inst_tcs, is_tvs = tvs, + ispec@(ClsInst { is_tcs = inst_tcs, is_tvs = tvs, is_tys = tys }) <- cls_insts, -- Filter out ones that can't possibly match, -- based on the head of the fundep diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index d05495f7ac..1e99775906 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -9,7 +9,7 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( DFunId, OverlapFlag(..), - Instance(..), pprInstance, pprInstanceHdr, pprInstances, + ClsInst(..), pprInstance, pprInstanceHdr, pprInstances, instanceHead, mkLocalInstance, mkImportedInstance, instanceDFunId, setInstanceDFunId, instanceRoughTcs, @@ -47,8 +47,8 @@ import Data.Maybe ( isJust, isNothing ) %************************************************************************ \begin{code} -data Instance - = Instance { is_cls :: Name -- Class name +data ClsInst + = ClsInst { is_cls :: Name -- Class name -- Used for "rough matching"; see Note [Rough-match field] -- INVARIANT: is_tcs = roughMatchTcs is_tys @@ -117,15 +117,15 @@ being equal to * the InstDecl used to construct the Instance. \begin{code} -instanceDFunId :: Instance -> DFunId +instanceDFunId :: ClsInst -> DFunId instanceDFunId = is_dfun -setInstanceDFunId :: Instance -> DFunId -> Instance +setInstanceDFunId :: ClsInst -> DFunId -> ClsInst setInstanceDFunId ispec dfun = ASSERT( idType dfun `eqType` idType (is_dfun ispec) ) -- We need to create the cached fields afresh from -- the new dfun id. In particular, the is_tvs in - -- the Instance must match those in the dfun! + -- the ClsInst must match those in the dfun! -- We assume that the only thing that changes is -- the quantified type variables, so the other fields -- are ok; hence the assert @@ -133,27 +133,27 @@ setInstanceDFunId ispec dfun where (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) -instanceRoughTcs :: Instance -> [Maybe Name] +instanceRoughTcs :: ClsInst -> [Maybe Name] instanceRoughTcs = is_tcs \end{code} \begin{code} -instance NamedThing Instance where +instance NamedThing ClsInst where getName ispec = getName (is_dfun ispec) -instance Outputable Instance where +instance Outputable ClsInst where ppr = pprInstance -pprInstance :: Instance -> SDoc --- Prints the Instance as an instance declaration +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration pprInstance ispec = hang (pprInstanceHdr ispec) 2 (ptext (sLit "--") <+> pprDefinedAt (getName ispec)) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree -pprInstanceHdr :: Instance -> SDoc --- Prints the Instance as an instance declaration -pprInstanceHdr ispec@(Instance { is_flag = flag }) +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr ispec@(ClsInst { is_flag = flag }) = ptext (sLit "instance") <+> ppr flag <+> sep [pprThetaArrowTy theta, ppr res_ty] where @@ -161,10 +161,10 @@ pprInstanceHdr ispec@(Instance { is_flag = flag }) (_, theta, res_ty) = tcSplitSigmaTy (idType dfun) -- Print without the for-all, which the programmer doesn't write -pprInstances :: [Instance] -> SDoc +pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) -instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type]) +instanceHead :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) instanceHead ispec = (tvs, theta, cls, tys) where (tvs, theta, tau) = tcSplitSigmaTy (idType dfun) @@ -173,21 +173,21 @@ instanceHead ispec = (tvs, theta, cls, tys) mkLocalInstance :: DFunId -> OverlapFlag - -> Instance + -> ClsInst -- Used for local instances, where we can safely pull on the DFunId mkLocalInstance dfun oflag - = Instance { is_flag = oflag, is_dfun = dfun, + = ClsInst { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, is_cls = className cls, is_tcs = roughMatchTcs tys } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) mkImportedInstance :: Name -> [Maybe Name] - -> DFunId -> OverlapFlag -> Instance + -> DFunId -> OverlapFlag -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file mkImportedInstance cls mb_tcs dfun oflag - = Instance { is_flag = oflag, is_dfun = dfun, + = ClsInst { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, is_cls = cls, is_tcs = mb_tcs } where @@ -354,13 +354,13 @@ or, to put it another way, we have type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class newtype ClsInstEnv - = ClsIE [Instance] -- The instances for a particular class, in any order + = ClsIE [ClsInst] -- The instances for a particular class, in any order instance Outputable ClsInstEnv where ppr (ClsIE is) = pprInstances is -- INVARIANTS: --- * The is_tvs are distinct in each Instance +-- * The is_tvs are distinct in each ClsInst -- of a ClsInstEnv (so we can safely unify them) -- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: @@ -371,10 +371,10 @@ instance Outputable ClsInstEnv where emptyInstEnv :: InstEnv emptyInstEnv = emptyUFM -instEnvElts :: InstEnv -> [Instance] +instEnvElts :: InstEnv -> [ClsInst] instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts] -classInstances :: (InstEnv,InstEnv) -> Class -> [Instance] +classInstances :: (InstEnv,InstEnv) -> Class -> [ClsInst] classInstances (pkg_ie, home_ie) cls = get home_ie ++ get pkg_ie where @@ -382,24 +382,24 @@ classInstances (pkg_ie, home_ie) cls Just (ClsIE insts) -> insts Nothing -> [] -extendInstEnvList :: InstEnv -> [Instance] -> InstEnv +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs -extendInstEnv :: InstEnv -> Instance -> InstEnv -extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm }) +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm }) = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) where add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) -overwriteInstEnv :: InstEnv -> Instance -> InstEnv -overwriteInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tys = tys }) +overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv +overwriteInstEnv inst_env ins_item@(ClsInst { is_cls = cls_nm, is_tys = tys }) = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) where add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts) rough_tcs = roughMatchTcs tys replaceInst [] = [ins_item] - replaceInst (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, + replaceInst (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs, is_tys = tpl_tys, is_dfun = dfun }) : rest) -- Fast check for no match, uses the "rough match" fields @@ -431,13 +431,13 @@ type InstTypes = [Either TyVar Type] -- Right ty => Instantiate with this type -- Left tv => Instantiate with any type of this tyvar's kind -type InstMatch = (Instance, InstTypes) +type InstMatch = (ClsInst, InstTypes) \end{code} Note [InstTypes: instantiating types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A successful match is an Instance, together with the types at which - the dfun_id in the Instance should be instantiated +A successful match is an ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated The instantiating types are (Either TyVar Type)s because the dfun might have some tyvars that *only* appear in arguments dfun :: forall a b. C a b, Ord b => D [a] @@ -454,7 +454,7 @@ where the 'Left b' indicates that 'b' can be freely instantiated. -- lookupUniqueInstEnv :: (InstEnv, InstEnv) -> Class -> [Type] - -> Either Message (Instance, [Type]) + -> Either MsgDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv instEnv cls tys of ([(inst, inst_tys)], _, _) @@ -472,7 +472,7 @@ lookupUniqueInstEnv instEnv cls tys lookupInstEnv' :: InstEnv -- InstEnv to look in -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches - [Instance]) -- These don't match but do unify + [ClsInst]) -- These don't match but do unify -- The second component of the result pair happens when we look up -- Foo [a] -- in an InstEnv that has entries for @@ -495,7 +495,7 @@ lookupInstEnv' ie cls tys -------------- find ms us [] = (ms, us) - find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, + find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs, is_tys = tpl_tys, is_flag = oflag, is_dfun = dfun }) : rest) -- Fast check for no match, uses the "rough match" fields @@ -537,7 +537,7 @@ lookupInstEnv' ie cls tys lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches - [Instance], -- These don't match but do unify + [ClsInst], -- These don't match but do unify Bool) -- True if error condition caused by -- SafeHaskell condition. diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index fa467a7f27..e919297717 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -30,7 +30,7 @@ module Kind ( pprKind, pprParendKind, -- ** Deconstructing Kinds - kindFunResult, kindAppResult, synTyConResKind, + kindAppResult, synTyConResKind, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, -- ** Predicates on Kinds @@ -48,10 +48,7 @@ module Kind ( -- ** Functions on variables isKiVar, splitKiTyVars, partitionKiTyVars, - kiVarsOfKind, kiVarsOfKinds, - - -- ** Promotion related functions - promoteType, isPromotableType, isPromotableKind, + kiVarsOfKind, kiVarsOfKinds ) where @@ -251,8 +248,10 @@ isSubKind' duringTc k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 -- handles BOX - = ASSERT2( isSuperKindTyCon kc2 && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) - True + = WARN( not (isSuperKindTyCon kc2 && isSuperKindTyCon kc2 + && null k1s && null k2s), + ppr kc1 <+> ppr kc2 ) + kc1 == kc2 | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) @@ -313,54 +312,4 @@ kiVarsOfKind = tyVarsOfType kiVarsOfKinds :: [Kind] -> VarSet kiVarsOfKinds = tyVarsOfTypes - --- Datatype promotion -isPromotableType :: Type -> Bool -isPromotableType = go emptyVarSet - where - go vars (TyConApp tc tys) = ASSERT( not (isPromotedDataTyCon tc) ) all (go vars) tys - go vars (FunTy arg res) = all (go vars) [arg,res] - go vars (TyVarTy tvar) = tvar `elemVarSet` vars - go vars (ForAllTy tvar ty) = isPromotableTyVar tvar && go (vars `extendVarSet` tvar) ty - go _ _ = panic "isPromotableType" -- argument was not kind-shaped - -isPromotableTyVar :: TyVar -> Bool -isPromotableTyVar = isLiftedTypeKind . varType - --- | Promotes a type to a kind. Assumes the argument is promotable. -promoteType :: Type -> Kind -promoteType (TyConApp tc tys) = mkTyConApp (mkPromotedTypeTyCon tc) - (map promoteType tys) - -- T t1 .. tn ~~> 'T k1 .. kn where ti ~~> ki -promoteType (FunTy arg res) = mkArrowKind (promoteType arg) (promoteType res) - -- t1 -> t2 ~~> k1 -> k2 where ti ~~> ki -promoteType (TyVarTy tvar) = mkTyVarTy (promoteTyVar tvar) - -- a :: * ~~> a :: BOX -promoteType (ForAllTy tvar ty) = ForAllTy (promoteTyVar tvar) (promoteType ty) - -- forall (a :: *). t ~~> forall (a :: BOX). k where t ~~> k -promoteType _ = panic "promoteType" -- argument was not kind-shaped - -promoteTyVar :: TyVar -> KindVar -promoteTyVar tvar = mkKindVar (tyVarName tvar) tySuperKind - --- If kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ] -isPromotableKind :: Kind -> Maybe Int -isPromotableKind kind = - let (args, res) = splitKindFunTys kind in - if all isLiftedTypeKind (res:args) - then Just $ length args - else Nothing - -{- Note [Promoting a Type to a Kind] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only promote the followings. -- Type variables: a -- Fully applied arrow types: tau -> sigma -- Fully applied type constructors of kind: - n >= 0 - /-----------\ - * -> ... -> * -> * -- Polymorphic types over type variables of kind star: - forall (a::*). tau --} \end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index f8745e62fb..e2c192f435 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -22,7 +22,9 @@ module TyCon( SynTyConRhs(..), -- ** Coercion axiom constructors - CoAxiom(..), coAxiomName, coAxiomArity, + CoAxiom(..), + coAxiomName, coAxiomArity, coAxiomTyVars, + coAxiomLHS, coAxiomRHS, isImplicitCoAxiom, -- ** Constructing TyCons mkAlgTyCon, @@ -37,7 +39,7 @@ module TyCon( mkSuperKindTyCon, mkForeignTyCon, mkPromotedDataTyCon, - mkPromotedTypeTyCon, + mkPromotedTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -71,7 +73,7 @@ module TyCon( tyConArity, tyConParent, tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe, - tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, synTyConDefn, synTyConRhs, synTyConType, tyConExtName, -- External name for foreign types algTyConRhs, @@ -92,7 +94,7 @@ module TyCon( #include "HsVersions.h" import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) -import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConName ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import {-# SOURCE #-} IParam ( ipTyConName ) import Var @@ -138,48 +140,11 @@ Note [Type synonym families] translates to a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon -* Translation of type instance decl: - type instance F [a] = Maybe a - translates to a "representation TyCon", 'R:FList', where - R:FList is a SynTyCon, whose - SynTyConRhs is (SynonymTyCon (Maybe a)) - TyConParent is (FamInstTyCon F [a] co) - where co :: F [a] ~ R:FList a - - It's very much as if the user had written - type instance F [a] = R:FList a - type R:FList a = Maybe a - Indeed, in GHC's internal representation, the RHS of every - 'type instance' is simply an application of the representation - TyCon to the quantified varaibles. - - The intermediate representation TyCon is a bit gratuitous, but - it means that: - - each 'type instance' decls is in 1-1 correspondance - with its representation TyCon - - So the result of typechecking a 'type instance' decl is just a - TyCon. In turn this means that type and data families can be - treated uniformly. - * Translation of type family decl: type family F a :: * translates to a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon -* Translation of type instance decl: - type instance F [a] = Maybe a - translates to - A SynTyCon 'R:FList a', whose - SynTyConRhs is (SynonymTyCon (Maybe a)) - TyConParent is (FamInstTyCon F [a] co) - where co :: F [a] ~ R:FList a - Notice that we introduce a gratuitous vanilla type synonym - type R:FList a = Maybe a - solely so that type and data families can be treated more - uniformly, via a single FamInstTyCon descriptor - * In the future we might want to support * closed type families (esp when we have proper kinds) * injective type families (allow decomposition) @@ -445,6 +410,7 @@ data TyCon | PromotedDataTyCon { -- See Note [Promoted data constructors] tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor + tyConArity :: Arity, tc_kind :: Kind, -- ^ Translated type of the data constructor dataCon :: DataCon -- ^ Corresponding data constructor } @@ -454,6 +420,7 @@ data TyCon tyConUnique :: Unique, -- ^ Same Unique as the type constructor tyConName :: Name, -- ^ Same Name as the type constructor tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times + tc_kind :: Kind, -- ^ Always tySuperKind ty_con :: TyCon -- ^ Corresponding type constructor } @@ -570,7 +537,7 @@ data TyConParent Class -- The class in whose declaration the family is declared -- See Note [Associated families and their parent class] - -- | Type constructors representing an instance of a type family. Parameters: + -- | Type constructors representing an instance of a *data* family. Parameters: -- -- 1) The type family in question -- @@ -581,11 +548,17 @@ data TyConParent -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family | FamInstTyCon -- See Note [Data type families] - -- and Note [Type synonym families] + CoAxiom -- The coercion constructor, + -- always of kind T ty1 ty2 ~ R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon TyCon -- The family TyCon [Type] -- Argument types (mentions the tyConTyVars of this TyCon) -- Match in length the tyConTyVars of the family TyCon - CoAxiom -- The coercion constructor -- E.g. data intance T [a] = ... -- gives a representation tycon: @@ -598,15 +571,15 @@ instance Outputable TyConParent where ppr (ClassTyCon cls) = text "Class parent" <+> ppr cls ppr (IPTyCon n) = text "IP parent" <+> ppr n ppr (AssocFamilyTyCon cls) = text "Class parent (assoc. family)" <+> ppr cls - ppr (FamInstTyCon tc tys _) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys) + ppr (FamInstTyCon _ tc tys) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys) -- | Checks the invariants of a 'TyConParent' given the appropriate type class name, if any okParent :: Name -> TyConParent -> Bool -okParent _ NoParentTyCon = True -okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) -okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) -okParent tc_name (IPTyCon ip) = tc_name == ipTyConName ip -okParent _ (FamInstTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys +okParent _ NoParentTyCon = True +okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) +okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) +okParent tc_name (IPTyCon ip) = tc_name == ipTyConName ip +okParent _ (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys isNoParent :: TyConParent -> Bool isNoParent NoParentTyCon = True @@ -676,23 +649,21 @@ See Trac #4528. Note [Newtype coercions] ~~~~~~~~~~~~~~~~~~~~~~~~ -The NewTyCon field nt_co is a a TyCon (a coercion constructor in fact) -which is used for coercing from the representation type of the -newtype, to the newtype itself. For example, +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, newtype T a = MkT (a -> a) -the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> -t. This TyCon is a CoTyCon, so it does not have a kind on its -own; it basically has its own typing rule for the fully-applied -version. If the newtype T has k type variables then CoT has arity at -most k. In the case that the right hand side is a type application +the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. + +In the case that the right hand side is a type application ending with the same type variables as the left hand side, we "eta-contract" the coercion. So if we had newtype S a = MkT [a] -then we would generate the arity 0 coercion CoS : S ~ []. The +then we would generate the arity 0 axiom CoS : S ~ []. The primary reason we do this is to make newtype deriving cleaner. In the paper we'd write @@ -701,14 +672,6 @@ and then when we used CoT at a particular type, s, we'd say CoT @ s which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) -But in GHC we instead make CoT into a new piece of type syntax, CoTyCon, -(like instCoercionTyCon, symCoercionTyCon etc), which must always -be saturated, but which encodes as - TyConApp CoT [s] -In the vocabulary of the paper it's as if we had axiom declarations -like - axiom CoT t : T t ~ [t] - Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider @@ -757,12 +720,14 @@ so the coercion tycon CoT must have \begin{code} -- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. data CoAxiom - = CoAxiom -- type equality axiom. - { co_ax_unique :: Unique -- unique identifier - , co_ax_name :: Name -- name for pretty-printing - , co_ax_tvs :: [TyVar] -- bound type variables - , co_ax_lhs :: Type -- left-hand side of the equality - , co_ax_rhs :: Type -- right-hand side of the equality + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- unique identifier + , co_ax_name :: Name -- name for pretty-printing + , co_ax_tvs :: [TyVar] -- bound type variables + , co_ax_lhs :: Type -- left-hand side of the equality + , co_ax_rhs :: Type -- right-hand side of the equality + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] } deriving Typeable @@ -771,8 +736,29 @@ coAxiomArity ax = length (co_ax_tvs ax) coAxiomName :: CoAxiom -> Name coAxiomName = co_ax_name + +coAxiomTyVars :: CoAxiom -> [TyVar] +coAxiomTyVars = co_ax_tvs + +coAxiomLHS, coAxiomRHS :: CoAxiom -> Type +coAxiomLHS = co_ax_lhs +coAxiomRHS = co_ax_rhs + +isImplicitCoAxiom :: CoAxiom -> Bool +isImplicitCoAxiom = co_ax_implicit \end{code} +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in HscTypes +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration + %************************************************************************ %* * @@ -977,25 +963,30 @@ mkSuperKindTyCon name } -- | Create a promoted data constructor 'TyCon' -mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> TyCon -mkPromotedDataTyCon con name unique kind +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself +mkPromotedDataTyCon :: DataCon -> Name -> Unique -> Kind -> Arity -> TyCon +mkPromotedDataTyCon con name unique kind arity = PromotedDataTyCon { - tyConName = name, + tyConName = name, tyConUnique = unique, - tc_kind = kind, - dataCon = con + tyConArity = arity, + tc_kind = kind, + dataCon = con } -- | Create a promoted type constructor 'TyCon' -mkPromotedTypeTyCon :: TyCon -> TyCon -mkPromotedTypeTyCon con +-- Somewhat dodgily, we give it the same Name +-- as the type constructor itself +mkPromotedTyCon :: TyCon -> Kind -> TyCon +mkPromotedTyCon tc kind = PromotedTypeTyCon { - tyConName = getName con, - tyConUnique = getUnique con, - tyConArity = tyConArity con, - ty_con = con + tyConName = getName tc, + tyConUnique = getUnique tc, + tyConArity = tyConArity tc, + tc_kind = kind, + ty_con = tc } - \end{code} \begin{code} @@ -1251,12 +1242,13 @@ isPromotedTypeTyCon _ = False -- * Family instances are /not/ implicit as they represent the instance body -- (similar to a @dfun@ does that for a class instance). isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon tycon | isTyConAssoc tycon = True - | isSynTyCon tycon = False - | isAlgTyCon tycon = isTupleTyCon tycon -isImplicitTyCon _other = True - -- catches: FunTyCon, PrimTyCon, - -- CoTyCon, SuperKindTyCon +isImplicitTyCon tycon + | isTyConAssoc tycon = True + | isSynTyCon tycon = False + | isAlgTyCon tycon = isTupleTyCon tycon + | otherwise = True + -- 'otherwise' catches: FunTyCon, PrimTyCon, + -- PromotedDataCon, PomotedTypeTyCon, SuperKindTyCon \end{code} @@ -1303,15 +1295,9 @@ expand tvs rhs tys \end{code} \begin{code} - tyConKind :: TyCon -> Kind -tyConKind (FunTyCon { tc_kind = k }) = k -tyConKind (AlgTyCon { tc_kind = k }) = k -tyConKind (TupleTyCon { tc_kind = k }) = k -tyConKind (SynTyCon { tc_kind = k }) = k -tyConKind (PrimTyCon { tc_kind = k }) = k -tyConKind (PromotedDataTyCon { tc_kind = k }) = k -tyConKind tc = pprPanic "tyConKind" (ppr tc) -- SuperKindTyCon and CoTyCon +tyConKind (SuperKindTyCon {}) = pprPanic "tyConKind" empty +tyConKind tc = tc_kind tc tyConHasKind :: TyCon -> Bool tyConHasKind (SuperKindTyCon {}) = False @@ -1465,15 +1451,15 @@ isFamInstTyCon tc = case tyConParent tc of tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom) tyConFamInstSig_maybe tc = case tyConParent tc of - FamInstTyCon f ts co_tc -> Just (f, ts, co_tc) - _ -> Nothing + FamInstTyCon ax f ts -> Just (f, ts, ax) + _ -> Nothing -- | If this 'TyCon' is that of a family instance, return the family in question -- and the instance types. Otherwise, return @Nothing@ tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) tyConFamInst_maybe tc = case tyConParent tc of - FamInstTyCon f ts _ -> Just (f, ts) + FamInstTyCon _ f ts -> Just (f, ts) _ -> Nothing -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents @@ -1482,7 +1468,7 @@ tyConFamInst_maybe tc tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom tyConFamilyCoercion_maybe tc = case tyConParent tc of - FamInstTyCon _ _ co -> Just co + FamInstTyCon co _ _ -> Just co _ -> Nothing \end{code} @@ -1514,8 +1500,7 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr (PromotedDataTyCon {dataCon = dc}) = quote (ppr (dataConName dc)) - ppr tc = ppr (getName tc) + ppr tc = ppr (tyConName tc) instance NamedThing TyCon where getName = tyConName diff --git a/compiler/types/TyCon.lhs-boot b/compiler/types/TyCon.lhs-boot index dcf41dd545..d8ddff3f40 100644 --- a/compiler/types/TyCon.lhs-boot +++ b/compiler/types/TyCon.lhs-boot @@ -1,11 +1,4 @@ \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TyCon where import Name (Name) @@ -13,9 +6,9 @@ import Unique (Unique) data TyCon -tyConName :: TyCon -> Name -tyConUnique :: TyCon -> Unique -isTupleTyCon :: TyCon -> Bool +tyConName :: TyCon -> Name +tyConUnique :: TyCon -> Unique +isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool \end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 6d1050fde2..26526abbf0 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -274,7 +274,7 @@ isLiftedTypeKind _ = False \begin{code} tyVarsOfType :: Type -> VarSet -- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym --- tyVarsOfType returns only the free *type* variables of a type +-- tyVarsOfType returns only the free variables of a type -- For example, tyVarsOfType (a::k) returns {a}, not including the -- kind variable {k} tyVarsOfType (TyVarTy v) = unitVarSet v @@ -511,7 +511,9 @@ instance Outputable Type where ppr ty = pprType ty instance Outputable name => OutputableBndr (IPName name) where - pprBndr _ n = ppr n -- Simple for now + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n ------------------ -- OK, here's the main printer diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 9a8cafc9ec..7d648aef7e 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -579,7 +579,7 @@ data BindFlag \begin{code} newtype UM a = UM { unUM :: (TyVar -> BindFlag) - -> MaybeErr Message a } + -> MaybeErr MsgDoc a } instance Monad UM where return a = UM (\_tvs -> Succeeded a) @@ -588,13 +588,13 @@ instance Monad UM where Failed err -> Failed err Succeeded v -> unUM (k v) tvs) -initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr Message a +initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr MsgDoc a initUM badtvs um = unUM um badtvs tvBindFlag :: TyVar -> UM BindFlag tvBindFlag tv = UM (\tv_fn -> Succeeded (tv_fn tv)) -failWith :: Message -> UM a +failWith :: MsgDoc -> UM a failWith msg = UM (\_tv_fn -> Failed msg) maybeErrToMaybe :: MaybeErr fail succ -> Maybe succ diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index bfddf5b322..feb4be50c1 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -76,6 +76,7 @@ import Foreign import Data.Array import Data.IORef import Data.Char ( ord, chr ) +import Data.Time import Data.Typeable #if __GLASGOW_HASKELL__ >= 701 import Data.Typeable.Internal @@ -488,6 +489,23 @@ instance (Binary a, Binary b) => Binary (Either a b) where 0 -> do a <- get bh ; return (Left a) _ -> do b <- get bh ; return (Right b) +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + #if defined(__GLASGOW_HASKELL__) || 1 --to quote binary-0.3 on this code idea, -- diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index c029e4a8e0..ee7e616305 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -30,6 +30,7 @@ module IOEnv ( atomicUpdMutVar, atomicUpdMutVar' ) where +import DynFlags import Exception import Panic @@ -88,6 +89,10 @@ instance Show IOEnvFailure where instance Exception IOEnvFailure +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $ extractDynFlags env + ---------------------------------------------------------------------- -- Fundmantal combinators specific to the monad ---------------------------------------------------------------------- diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index d7bbc54cc7..c506e23410 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -22,7 +22,7 @@ module Outputable ( empty, nest, char, text, ftext, ptext, - int, integer, float, double, rational, + int, intWithCommas, integer, float, double, rational, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, @@ -48,7 +48,7 @@ module Outputable ( renderWithStyle, pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsInfix, pprHsVar, + pprHsChar, pprHsString, pprFastFilePath, -- * Controlling the style in which output is printed @@ -745,6 +745,11 @@ data BindingSite = LambdaBind | CaseBind | LetBind class Outputable a => OutputableBndr a where pprBndr :: BindingSite -> a -> SDoc pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) \end{code} %************************************************************************ @@ -779,27 +784,6 @@ pprInfixVar is_operator pp_v | otherwise = char '`' <> pp_v <> char '`' --------------------- --- pprHsVar and pprHsInfix use the gruesome isOperator, which --- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v). --- Reason: it means that pprHsVar doesn't need a NamedThing context, --- which none of the HsSyn printing functions do -pprHsVar, pprHsInfix :: Outputable name => name -> SDoc -pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v - where pp_v = ppr v -pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v - where pp_v = ppr v - -isOperator :: SDoc -> Bool -isOperator ppr_v - = case showSDocUnqual ppr_v of - ('(':_) -> False -- (), (,) etc - ('[':_) -> False -- [] - ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator - (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator - ('_':_) -> False -- Not an operator - (c:_) -> not (isAlpha c) -- Starts with non-alpha - _ -> False - pprFastFilePath :: FastString -> SDoc pprFastFilePath path = text $ normalise $ unpackFS path \end{code} @@ -848,6 +832,15 @@ quotedListWithOr xs = quotedList xs %************************************************************************ \begin{code} +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + -- | Converts an integer to a verbal index: -- -- > speakNth 1 = text "first" diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 7253af1274..66f51e64e6 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -14,14 +14,13 @@ module Platform ( where -import Panic - -- | Contains enough information for the native code generator to emit -- code for this platform. data Platform = Platform { platformArch :: Arch, platformOS :: OS, + platformWordSize :: {-# UNPACK #-} !Int, platformHasGnuNonexecStack :: Bool, platformHasIdentDirective :: Bool, platformHasSubsectionsViaSymbols :: Bool @@ -55,8 +54,10 @@ data OS | OSSolaris2 | OSMinGW32 | OSFreeBSD + | OSDragonFly | OSOpenBSD | OSNetBSD + | OSKFreeBSD deriving (Read, Show, Eq) -- | ARM Instruction Set Architecture and Extensions @@ -77,24 +78,21 @@ data ArmISAExt target32Bit :: Platform -> Bool -target32Bit p = case platformArch p of - ArchUnknown -> panic "Don't know if ArchUnknown is 32bit" - ArchX86 -> True - ArchX86_64 -> False - ArchPPC -> True - ArchPPC_64 -> False - ArchSPARC -> True - ArchARM _ _ -> True - +target32Bit p = platformWordSize p == 4 -- | This predicates tells us whether the OS supports ELF-like shared libraries. osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSOpenBSD = True -osElfTarget OSNetBSD = True -osElfTarget OSSolaris2 = True -osElfTarget OSDarwin = False -osElfTarget OSMinGW32 = False -osElfTarget OSUnknown = panic "Don't know if OSUnknown is elf" - +osElfTarget OSLinux = True +osElfTarget OSFreeBSD = True +osElfTarget OSDragonFly = True +osElfTarget OSOpenBSD = True +osElfTarget OSNetBSD = True +osElfTarget OSSolaris2 = True +osElfTarget OSDarwin = False +osElfTarget OSMinGW32 = False +osElfTarget OSKFreeBSD = True +osElfTarget OSUnknown = False + -- Defaulting to False is safe; it means don't rely on any + -- ELF-specific functionality. It is important to have a default for + -- portability, otherwise we have to answer this question for every + -- new platform we compile on (even unreg). diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 0720eae113..d09a1ad345 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -1,17 +1,11 @@ % % (c) The University of Glasgow 2006 -% (c) The University of Glasgow 1992-2002 % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details -- | Highly random utility functions +-- module Util ( -- * Flags dependent on the compiler build ghciSupported, debugIsOn, ncgDebugIsOn, @@ -21,13 +15,13 @@ module Util ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, - + unzipWith, - + mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, nOfThem, filterOut, partitionWith, splitEithers, - + foldl1', foldl2, count, all2, lengthExceeds, lengthIs, lengthAtLeast, @@ -51,13 +45,13 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, minWith, on, + sortLe, sortWith, minWith, on, -- * Comparisons isEqual, eqListBy, eqMaybeBy, thenCmp, cmpList, removeSpaces, - + -- * Edit distance fuzzyMatch, fuzzyLookup, @@ -82,6 +76,7 @@ module Util ( -- * IO-ish utilities createDirectoryHierarchy, doesDirNameExist, + getModificationUTCTime, modificationTimeIfExists, global, consIORef, globalM, @@ -119,7 +114,6 @@ import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) import System.FilePath -import System.Time ( ClockTime ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) import Data.Ratio ( (%) ) @@ -128,6 +122,12 @@ import Data.Bits import Data.Word import qualified Data.IntMap as IM +import Data.Time +#if __GLASGOW_HASKELL__ < 705 +import Data.Time.Clock.POSIX +import System.Time +#endif + infixr 9 `thenCmp` \end{code} @@ -219,9 +219,9 @@ nTimes n f = f . nTimes (n-1) f \end{code} \begin{code} -fstOf3 :: (a,b,c) -> a -sndOf3 :: (a,b,c) -> b -thirdOf3 :: (a,b,c) -> c +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thirdOf3 :: (a,b,c) -> c fstOf3 (a,_,_) = a sndOf3 (_,b,_) = b thirdOf3 (_,_,c) = c @@ -759,8 +759,8 @@ restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 restrictedDamerauLevenshteinDistance' - :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int -restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 | [] <- str1 = n | otherwise = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker @@ -772,7 +772,7 @@ restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 extractAnswer (_, _, _, _, distance) = distance restrictedDamerauLevenshteinDistanceWorker - :: (Bits bv) => IM.IntMap bv -> bv -> bv + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2 @@ -782,26 +782,26 @@ restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm', d0', vp', vn', distance'') where pm' = IM.findWithDefault 0 (ord char2) str1_mvs - + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn -- No need to mask the shiftL because of the restricted range of pm hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp - + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask hn'_shift = (hn' `shiftL` 1) .&. vector_mask vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) vn' = d0' .&. hp'_shift - + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' sizedComplement :: Bits bv => bv -> bv -> bv sizedComplement vector_mask vect = vector_mask `xor` vect -matchVectors :: Bits bv => String -> IM.IntMap bv +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv matchVectors = snd . foldl' go (0 :: Int, IM.empty) where go (ix, im) char = let ix' = ix + 1 @@ -843,16 +843,16 @@ fuzzyLookup user_entered possibilites poss_str user_entered , distance <= fuzzy_threshold ] where - -- Work out an approriate match threshold: - -- We report a candidate if its edit distance is <= the threshold, + -- Work out an approriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, -- The threshhold is set to about a quarter of the # of characters the user entered - -- Length Threshold - -- 1 0 -- Don't suggest *any* candidates - -- 2 1 -- for single-char identifiers - -- 3 1 - -- 4 1 - -- 5 1 - -- 6 2 + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 -- fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) mAX_RESULTS = 3 @@ -1035,12 +1035,24 @@ doesDirNameExist fpath = case takeDirectory fpath of "" -> return True -- XXX Hack _ -> doesDirectoryExist (takeDirectory fpath) +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +#if __GLASGOW_HASKELL__ < 705 +getModificationUTCTime f = do + TOD secs _ <- getModificationTime f + return $ posixSecondsToUTCTime (realToFrac secs) +#else +getModificationUTCTime = getModificationTime +#endif + -- -------------------------------------------------------------- -- check existence & modification time at the same time -modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) modificationTimeIfExists f = do - (do t <- getModificationTime f; return (Just t)) + (do t <- getModificationUTCTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing else ioError e @@ -1129,14 +1141,15 @@ abstractDataType n = mkDataType n [abstractConstr n] \begin{code} charToC :: Word8 -> String -charToC w = +charToC w = case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] | otherwise -> ['\\', chr (ord '0' + ord c `div` 64), chr (ord '0' + ord c `div` 8 `mod` 8), chr (ord '0' + ord c `mod` 8)] \end{code} + diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs index 0af5fe0776..d73bea17ee 100644 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -44,13 +44,14 @@ import Name -- buildPADict :: TyCon -- ^ tycon of the type being vectorised. - -> TyCon -- ^ tycon of the type used for the vectorised representation. + -> CoAxiom -- ^ Coercion between the type and + -- its vectorised representation. -> TyCon -- ^ PData instance tycon -> TyCon -- ^ PDatas instance tycon -> SumRepr -- ^ representation used for the type being vectorised. -> VM Var -- ^ name of the top-level dictionary function. -buildPADict vect_tc prepr_tc pdata_tc pdatas_tc repr +buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda -- abstract over; and they are put in the -- envt, so when we need a (PA a) we can @@ -94,7 +95,7 @@ buildPADict vect_tc prepr_tc pdata_tc pdatas_tc repr method args dfun_name (name, build) = localV - $ do expr <- build vect_tc prepr_tc pdata_tc pdatas_tc repr + $ do expr <- build vect_tc prepr_ax pdata_tc pdatas_tc repr let body = mkLams (tvs ++ args) expr raw_var <- newExportedVar (method_name dfun_name name) (exprType body) let var = raw_var diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index 85e33367d7..ce2d947519 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -15,10 +15,10 @@ import Vectorise.Builtins import Vectorise.Generic.Description import CoreSyn import CoreUtils +import FamInstEnv import MkCore ( mkWildCase ) import TyCon import Type -import BuildTyCl import OccName import Coercion import MkId @@ -29,26 +29,15 @@ import Control.Monad import Outputable -buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPReprTyCon orig_tc vect_tc repr = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon - liftDs $ buildSynTyCon name - tyvars - (SynonymTyCon rhs_ty) - (typeKind rhs_ty) - NoParentTyCon - (Just $ mk_fam_inst prepr_tc vect_tc) + return $ mkSynFamInst name tyvars prepr_tc instTys rhs_ty where tyvars = tyConTyVars vect_tc - - -mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) -mk_fam_inst fam_tc arg_tc - = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) - - + instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc] -- buildPAScAndMethods -------------------------------------------------------- @@ -69,7 +58,7 @@ mk_fam_inst fam_tc arg_tc -- type PAInstanceBuilder = TyCon -- ^ Vectorised TyCon - -> TyCon -- ^ Representation TyCon + -> CoAxiom -- ^ Coercion to the representation TyCon -> TyCon -- ^ 'PData' TyCon -> TyCon -- ^ 'PDatas' TyCon -> SumRepr -- ^ Description of generic representation. @@ -88,8 +77,8 @@ buildPAScAndMethods buildPRDict :: PAInstanceBuilder -buildPRDict vect_tc prepr_tc _ _ _ - = prDictOfPReprInstTyCon inst_ty prepr_tc arg_tys +buildPRDict vect_tc prepr_ax _ _ _ + = prDictOfPReprInstTyCon inst_ty prepr_ax arg_tys where arg_tys = mkTyVarTys (tyConTyVars vect_tc) inst_ty = mkTyConApp vect_tc arg_tys @@ -98,7 +87,7 @@ buildPRDict vect_tc prepr_tc _ _ _ -- buildToPRepr --------------------------------------------------------------- -- | Build the 'toRepr' method of the PA class. buildToPRepr :: PAInstanceBuilder -buildToPRepr vect_tc repr_tc _ _ repr +buildToPRepr vect_tc repr_ax _ _ repr = do let arg_ty = mkTyConApp vect_tc ty_args -- Get the representation type of the argument. @@ -114,7 +103,7 @@ buildToPRepr vect_tc repr_tc _ _ repr where ty_args = mkTyVarTys (tyConTyVars vect_tc) - wrap_repr_inst = wrapFamInstBody repr_tc ty_args + wrap_repr_inst = wrapTypeFamInstBody repr_ax ty_args -- CoreExp to convert the given argument to the generic representation. -- We start by doing a case branch on the possible data constructors. @@ -172,12 +161,12 @@ buildToPRepr vect_tc repr_tc _ _ repr -- |Build the 'fromPRepr' method of the PA class. -- buildFromPRepr :: PAInstanceBuilder -buildFromPRepr vect_tc repr_tc _ _ repr +buildFromPRepr vect_tc repr_ax _ _ repr = do arg_ty <- mkPReprType res_ty arg <- newLocalVar (fsLit "x") arg_ty - result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg)) + result <- from_sum (unwrapTypeFamInstScrut repr_ax ty_args (Var arg)) repr return $ Lam arg result where @@ -225,14 +214,13 @@ buildFromPRepr vect_tc repr_tc _ _ repr -- |Build the 'toArrRepr' method of the PA class. -- buildToArrPRepr :: PAInstanceBuilder -buildToArrPRepr vect_tc prepr_tc pdata_tc _ r +buildToArrPRepr vect_tc repr_co pdata_tc _ r = do arg_ty <- mkPDataType el_ty res_ty <- mkPDataType =<< mkPReprType el_ty arg <- newLocalVar (fsLit "xs") arg_ty pdata_co <- mkBuiltinCo pdataTyCon - let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCo pdata_co + let co = mkAppCo pdata_co . mkSymCo $ mkAxInstCo repr_co ty_args @@ -291,13 +279,12 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc _ r -- |Build the 'fromArrPRepr' method for the PA class. -- buildFromArrPRepr :: PAInstanceBuilder -buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r +buildFromArrPRepr vect_tc repr_co pdata_tc _ r = do arg_ty <- mkPDataType =<< mkPReprType el_ty res_ty <- mkPDataType el_ty arg <- newLocalVar (fsLit "xs") arg_ty pdata_co <- mkBuiltinCo pdataTyCon - let Just repr_co = tyConFamilyCoercion_maybe prepr_tc let co = mkAppCo pdata_co $ mkAxInstCo repr_co var_tys @@ -367,7 +354,7 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r -- | Build the 'toArrPReprs' instance for the PA class. -- This converts a PData of elements into the generic representation. buildToArrPReprs :: PAInstanceBuilder -buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r +buildToArrPReprs vect_tc repr_co _ pdatas_tc r = do -- The argument type of the instance. -- eg: 'PDatas (Tree a b)' @@ -383,7 +370,6 @@ buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r -- Coersion to case between the (PRepr a) type and its instance. pdatas_co <- mkBuiltinCo pdatasTyCon - let Just repr_co = tyConFamilyCoercion_maybe prepr_tc let co = mkAppCo pdatas_co . mkSymCo $ mkAxInstCo repr_co ty_args @@ -457,7 +443,7 @@ buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r -- buildFromArrPReprs --------------------------------------------------------- buildFromArrPReprs :: PAInstanceBuilder -buildFromArrPReprs vect_tc prepr_tc _ pdatas_tc r +buildFromArrPReprs vect_tc repr_co _ pdatas_tc r = do -- The argument type of the instance. -- eg: 'PDatas (PRepr (Tree a b))' @@ -471,9 +457,8 @@ buildFromArrPReprs vect_tc prepr_tc _ pdatas_tc r -- eg: (xss :: PDatas (PRepr (Tree a b))) varg <- newLocalVar (fsLit "xss") arg_ty - -- Build the coersion between PRepr and the instance type + -- Build the coercion between PRepr and the instance type pdatas_co <- mkBuiltinCo pdatasTyCon - let Just repr_co = tyConFamilyCoercion_maybe prepr_tc let co = mkAppCo pdatas_co $ mkAxInstCo repr_co var_tys diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 3587452951..1026e95029 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -18,6 +18,7 @@ import BuildTyCl import DataCon import TyCon import Type +import FamInstEnv import Name import Util import MonadUtils @@ -26,27 +27,36 @@ import Control.Monad -- buildPDataTyCon ------------------------------------------------------------ -- | Build the PData instance tycon for a given type constructor. -buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPDataTyCon orig_tc vect_tc repr - = fixV $ \repr_tc -> - do name' <- mkLocalisedName mkPDataTyConOcc orig_name - rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr - pdata <- builtin pdataTyCon + = fixV $ \fam_inst -> + do let repr_tc = dataFamInstRepTyCon fam_inst + name' <- mkLocalisedName mkPDataTyConOcc orig_name + rhs <- buildPDataTyConRhs orig_name vect_tc repr_tc repr + pdata <- builtin pdataTyCon + buildDataFamInst name' pdata vect_tc rhs + where + orig_name = tyConName orig_tc - liftDs $ buildAlgTyCon name' +buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst +buildDataFamInst name' fam_tc vect_tc rhs + = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' + + ; let fam_inst = mkDataFamInst axiom_name tyvars fam_tc pat_tys rep_tc + ax = famInstAxiom fam_inst + pat_tys = [mkTyConApp vect_tc (mkTyVarTys tyvars)] + rep_tc = buildAlgTyCon name' tyvars [] -- no stupid theta rhs rec_flag -- FIXME: is this ok? False -- not GADT syntax - NoParentTyCon - (Just $ mk_fam_inst pdata vect_tc) + (FamInstTyCon ax fam_tc pat_tys) + ; return fam_inst } where - orig_name = tyConName orig_tc tyvars = tyConTyVars vect_tc rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) - buildPDataTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs buildPDataTyConRhs orig_name vect_tc repr_tc repr = do data_con <- buildPDataDataCon orig_name vect_tc repr_tc repr @@ -74,26 +84,16 @@ buildPDataDataCon orig_name vect_tc repr_tc repr -- buildPDatasTyCon ----------------------------------------------------------- -- | Build the PDatas instance tycon for a given type constructor. -buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon +buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPDatasTyCon orig_tc vect_tc repr - = fixV $ \repr_tc -> - do name' <- mkLocalisedName mkPDatasTyConOcc orig_name - rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr - pdatas <- builtin pdatasTyCon - - liftDs $ buildAlgTyCon name' - tyvars - [] -- no stupid theta - rhs - rec_flag -- FIXME: is this ok? - False -- not GADT syntax - NoParentTyCon - (Just $ mk_fam_inst pdatas vect_tc) + = fixV $ \fam_inst -> + do let repr_tc = dataFamInstRepTyCon fam_inst + name' <- mkLocalisedName mkPDatasTyConOcc orig_name + rhs <- buildPDatasTyConRhs orig_name vect_tc repr_tc repr + pdatas <- builtin pdatasTyCon + buildDataFamInst name' pdatas vect_tc rhs where - orig_name = tyConName orig_tc - tyvars = tyConTyVars vect_tc - rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) - + orig_name = tyConName orig_tc buildPDatasTyConRhs :: Name -> TyCon -> TyCon -> SumRepr -> VM AlgTyConRhs buildPDatasTyConRhs orig_name vect_tc repr_tc repr @@ -145,7 +145,8 @@ mkSumTys repr_selX_ty mkTc repr comp_ty r = mkTc (compOrigType r) - +{- mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) mk_fam_inst fam_tc arg_tc = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) +-}
\ No newline at end of file diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index a6bf6d973f..426682cea8 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -54,12 +54,12 @@ initV :: HscEnv -> VM a -> IO (Maybe (VectInfo, a)) initV hsc_env guts info thing_inside - = do { - let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) + = do { dumpIfVtTrace "Incoming VectInfo" (ppr info) + + ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) ; (_, Just res) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) type_env go - ; dumpIfVtTrace "Incoming VectInfo" (ppr info) ; case res of Nothing -> dumpIfVtTrace "Vectorisation FAILED!" empty diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index c36f179229..971fd8ff1f 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -57,7 +57,8 @@ lookupFamInst tycon tys = ASSERT( isFamilyTyCon tycon ) do { instEnv <- readGEnv global_fam_inst_env ; case lookupFamInstEnv instEnv tycon tys of - [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys) + [(fam_inst, rep_tys)] -> return ( dataFamInstRepTyCon fam_inst + , rep_tys) _other -> cantVectorise "VectMonad.lookupFamInst: not found: " (ppr $ mkTyConApp tycon tys) diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs index ecf0e81306..30b8a0e1e4 100644 --- a/compiler/vectorise/Vectorise/Monad/Naming.hs +++ b/compiler/vectorise/Vectorise/Monad/Naming.hs @@ -2,6 +2,7 @@ module Vectorise.Monad.Naming ( mkLocalisedName + , mkDerivedName , mkVectId , cloneVar , newExportedVar @@ -35,16 +36,25 @@ import Control.Monad -- always an internal system name. -- mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name -mkLocalisedName mk_occ name = - do { mod <- liftDs getModuleDs - ; u <- liftDs newUnique - ; let occ_name = mkLocalisedOccName mod mk_occ name - - new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name) - | otherwise = mkSystemName u occ_name - - ; return new_name - } +mkLocalisedName mk_occ name + = do { mod <- liftDs getModuleDs + ; u <- liftDs newUnique + ; let occ_name = mkLocalisedOccName mod mk_occ name + + new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name) + | otherwise = mkSystemName u occ_name + + ; return new_name } + +mkDerivedName :: (OccName -> OccName) -> Name -> VM Name +-- Similar to mkLocalisedName, but assumes the +-- incoming name is from this module. +-- Works on External names only +mkDerivedName mk_occ name + = do { u <- liftDs newUnique + ; return (mkExternalName u (nameModule name) + (mk_occ (nameOccName name)) + (nameSrcSpan name)) } -- |Produce the vectorised variant of an `Id` with the given vectorised type, while taking care that -- vectorised dfun ids must be dfuns again. diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 7122cb7664..ead7f14ea7 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/compiler/vectorise/Vectorise/Type/Classify.hs @@ -23,6 +23,7 @@ import DataCon import TyCon import TypeRep import Type +import PrelNames import Digraph @@ -54,14 +55,21 @@ classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs) where refs = ds `delListFromUniqSet` tcs - can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs + can_convert = (isNullUFM (refs `minusUFM` cs) && all convertable tcs) + || isShowClass tcs must_convert = foldUFM (||) False (intersectUFM_C const cs refs) + && (not . isShowClass $ tcs) -- We currently admit Haskell 2011-style data and newtype declarations as well as type -- constructors representing classes. convertable tc = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc) || isClassTyCon tc + + -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a + -- vectorised definition (to be able to vectorise 'Num') + isShowClass [tc] = tyConName tc == showClassName + isShowClass _ = False -- Used to group type constructors into mutually dependent groups. -- diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 5d2213ac26..0051d072a4 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -147,14 +147,6 @@ vectTypeEnv :: [TyCon] -- Type constructors defined in this mod vectTypeEnv tycons vectTypeDecls vectClassDecls = do { traceVt "** vectTypeEnv" $ ppr tycons - -- Build a map containing all vectorised type constructor. If they are scalar, they are - -- mapped to 'False' (vectorised type constructor == original type constructor). - ; allScalarTyConNames <- globalScalarTyCons -- covers both current and imported modules - ; vectTyCons <- globalVectTyCons - ; let vectTyConBase = mapNameEnv (const True) vectTyCons -- by default fully vectorised - vectTyConFlavour = foldNameSet (\n env -> extendNameEnv env n False) vectTyConBase - allScalarTyConNames - ; let -- {-# VECTORISE SCALAR type T -#} (imported and local tycons) localAbstractTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls] @@ -172,6 +164,23 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls localAbstractTyCons ++ map fst3 vectTyConsWithRHS notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames + -- Build a map containing all vectorised type constructor. If they are scalar, they are + -- mapped to 'False' (vectorised type constructor == original type constructor). + ; allScalarTyConNames <- globalScalarTyCons -- covers both current and imported modules + ; vectTyCons <- globalVectTyCons + ; let vectTyConBase = mapNameEnv (const True) vectTyCons -- by default fully vectorised + vectTyConFlavour = vectTyConBase + `plusNameEnv` + mkNameEnv [ (tyConName tycon, True) + | (tycon, _, _) <- vectTyConsWithRHS] + `plusNameEnv` + mkNameEnv [ (tcName, False) -- original representation + | tcName <- nameSetToList allScalarTyConNames] + `plusNameEnv` + mkNameEnv [ (tyConName tycon, False) -- original representation + | tycon <- localAbstractTyCons] + + -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2) -- that we could, but don't need to vectorise. Type constructors that are not data -- type constructors or use non-Haskell98 features are being dropped. They may not @@ -219,6 +228,12 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Vectorise all the data type declarations that we can and must vectorise (enter the -- type and data constructors into the vectorisation map on-the-fly.) ; new_tcs <- vectTyConDecls conv_tcs + + ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$ + ppr vTc <+> text "::" <+> ppr (dataConSig vTc)) + dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc + | otherwise = panic "dataConSig" + ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs) -- We don't need new representation types for dictionary constructors. The constructors -- are always fully applied, and we don't need to lift them to arrays as a dictionary @@ -229,12 +244,15 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Build 'PRepr' and 'PData' instance type constructors and family instances for all -- type constructors with vectorised representations. ; reprs <- mapM tyConRepr vect_tcs - ; repr_tcs <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs - ; pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs - ; pdatas_tcs <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs - - ; let inst_tcs = repr_tcs ++ pdata_tcs ++ pdatas_tcs - fam_insts = map mkLocalFamInst inst_tcs + ; repr_fis <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs + ; pdata_fis <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs + ; pdatas_fis <- zipWith3M buildPDatasTyCon orig_tcs vect_tcs reprs + + ; let fam_insts = repr_fis ++ pdata_fis ++ pdatas_fis + repr_axs = map famInstAxiom repr_fis + pdata_tcs = famInstsRepTyCons pdata_fis + pdatas_tcs = famInstsRepTyCons pdatas_fis + ; updGEnv $ extendFamEnv fam_insts -- Generate workers for the vectorised data constructors, dfuns for the 'PA' instances of @@ -262,7 +280,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; dfuns <- sequence $ zipWith4 buildTyConPADict vect_tcs - repr_tcs + repr_axs pdata_tcs pdatas_tcs @@ -272,7 +290,8 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Return the vectorised variants of type constructors as well as the generated instance -- type constructors, family instances, and dfun bindings. - ; return (new_tcs ++ inst_tcs ++ syn_tcs, fam_insts, binds) + ; return ( new_tcs ++ pdata_tcs ++ pdatas_tcs ++ syn_tcs + , fam_insts, binds) } where fst3 (a, _, _) = a @@ -319,9 +338,9 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Helpers -------------------------------------------------------------------- -buildTyConPADict :: TyCon -> TyCon -> TyCon -> TyCon -> VM Var -buildTyConPADict vect_tc prepr_tc pdata_tc pdatas_tc - = tyConRepr vect_tc >>= buildPADict vect_tc prepr_tc pdata_tc pdatas_tc +buildTyConPADict :: TyCon -> CoAxiom -> TyCon -> TyCon -> VM Var +buildTyConPADict vect_tc prepr_ax pdata_tc pdatas_tc + = tyConRepr vect_tc >>= buildPADict vect_tc prepr_ax pdata_tc pdatas_tc -- Produce a custom-made worker for the data constructors of a vectorised data type. This includes -- all data constructors that may be used in vetcorised code — i.e., all data constructors of data diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 88ff686452..9b830446c8 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -93,7 +93,7 @@ vectTyConDecl tycon name' gadt_flag = isGadtSyntaxTyCon tycon -- build the vectorised type constructor - ; liftDs $ buildAlgTyCon + ; return $ buildAlgTyCon name' -- new name (tyConTyVars tycon) -- keep original type vars [] -- no stupid theta @@ -101,7 +101,6 @@ vectTyConDecl tycon name' rec_flag -- whether recursive gadt_flag -- whether in GADT syntax NoParentTyCon - Nothing -- not a family instance } -- some other crazy thing that we don't handle diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index 0c111f49c7..2b47ddfb9b 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -36,7 +36,6 @@ import DataCon import MkId import FastString - -- Simple Types --------------------------------------------------------------- voidType :: VM Type diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 164ebae229..dfc08bcf58 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -113,20 +113,17 @@ paMethod method _ ty -- -- Note that @ty@ is only used for error messages -- -prDictOfPReprInstTyCon :: Type -> TyCon -> [Type] -> VM CoreExpr -prDictOfPReprInstTyCon ty prepr_tc prepr_args - | Just rhs <- coreView (mkTyConApp prepr_tc prepr_args) +prDictOfPReprInstTyCon :: Type -> CoAxiom -> [Type] -> VM CoreExpr +prDictOfPReprInstTyCon _ty prepr_ax prepr_args = do + let rhs = mkAxInstRHS prepr_ax prepr_args dict <- prDictOfReprType' rhs pr_co <- mkBuiltinCo prTyCon - let Just arg_co = tyConFamilyCoercion_maybe prepr_tc let co = mkAppCo pr_co $ mkSymCo - $ mkAxInstCo arg_co prepr_args + $ mkAxInstCo prepr_ax prepr_args return $ mkCast dict co - | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty) - -- |Get the PR dictionary for a type. The argument must be a representation -- type. -- |