diff options
| author | Iavor S. Diatchki <iavor.diatchki@gmail.com> | 2012-03-13 22:15:11 -0700 |
|---|---|---|
| committer | Iavor S. Diatchki <iavor.diatchki@gmail.com> | 2012-03-13 22:15:11 -0700 |
| commit | 1dd9b1ae1a5994a78ec1c4ca18c8df6e5b2ca9e0 (patch) | |
| tree | 78e4df29214ffbb8076bd00183ab6fbf68e17ffb | |
| parent | cfd89e12334e7dbcc8d9aaee898bcc38b77f549b (diff) | |
| parent | 93299cce9a4f7bc65b8164f779a37ef7f9f7c4a0 (diff) | |
| download | haskell-1dd9b1ae1a5994a78ec1c4ca18c8df6e5b2ca9e0.tar.gz | |
Merge remote-tracking branch 'origin/master' into type-nats
Conflicts:
compiler/coreSyn/CoreLint.lhs
compiler/deSugar/DsBinds.lhs
compiler/hsSyn/HsTypes.lhs
compiler/iface/IfaceType.lhs
compiler/rename/RnHsSyn.lhs
compiler/rename/RnTypes.lhs
compiler/stgSyn/StgLint.lhs
compiler/typecheck/TcHsType.lhs
compiler/utils/ListSetOps.lhs
202 files changed, 9417 insertions, 7791 deletions
@@ -50,12 +50,12 @@ For full information on building GHC, see the GHC Building Guide [3]. Here follows a summary - if you get into trouble, the Building Guide has all the answers. -NB. you need GHC installed in order to build GHC, because the compiler -is itself written in Haskell. For instructions on how to port GHC to a -new platform, see the Building Guide. +Before building GHC you may need to install some other tools and +libraries. See "Setting up your system for building GHC" [8]. -If you're building from git sources (as opposed to a source -distribution) then you also need to install Happy [4] and Alex [5]. +NB. in particular you need GHC installed in order to build GHC, +because the compiler is itself written in Haskell. For instructions +on how to port GHC to a new platform, see the Building Guide [3]. For building library documentation, you'll need Haddock [6]. To build the compiler documentation, you need a good DocBook XML toolchain and @@ -93,6 +93,7 @@ References [5] http://www.haskell.org/alex/ Alex [6] http://www.haskell.org/haddock/ Haddock [7] http://hackage.haskell.org/trac/ghc/wiki/Building/SyncAll + [8] http://hackage.haskell.org/trac/ghc/wiki/Building/Preparation Contributors diff --git a/aclocal.m4 b/aclocal.m4 index 9b8ad5ecc2..6d80ad3759 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -223,7 +223,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], netbsd) test -z "[$]2" || eval "[$]2=OSNetBSD" ;; - dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + haiku) + test -z "[$]2" || eval "[$]2=OSHaiku" + ;; + dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix) test -z "[$]2" || eval "[$]2=OSUnknown" ;; *) @@ -296,7 +299,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], # GET_ARM_ISA # ---------------------------------- -# Get info about the ISA on the Arm arch +# Get info about the ISA on the ARM arch AC_DEFUN([GET_ARM_ISA], [ AC_COMPILE_IFELSE([ @@ -486,7 +489,7 @@ AC_DEFUN([FP_VISIBILITY_HIDDEN], # FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN # ---------------------------------- -# Little endian Arm on Linux with some ABIs has big endian word order +# Little endian ARM on Linux with some ABIs has big endian word order # in doubles. Define FLOAT_WORDS_BIGENDIAN if this is the case. AC_DEFUN([FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN], [AC_CACHE_CHECK([whether float word order is big endian], [fptools_cv_float_word_order_bigendian], diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index e08bc67241..3ab3fd820f 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -53,6 +53,7 @@ module DataCon ( import Type import TypeRep( Type(..) ) -- Used in promoteType +import PrelNames( liftedTypeKindTyConKey ) import Kind import Unify import Coercion @@ -562,7 +563,7 @@ mkDataCon name declared_infix mkTyConApp rep_tycon (mkTyVarTys univ_tvs) eqSpecPreds :: [(TyVar,Type)] -> ThetaType -eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] +eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] mk_pred_strict_mark :: PredType -> HsBang mk_pred_strict_mark pred @@ -983,7 +984,7 @@ These two 'buildPromoted..' functions are here because \begin{code} buildPromotedTyCon :: TyCon -> TyCon buildPromotedTyCon tc - = mkPromotedTyCon tc tySuperKind + = mkPromotedTyCon tc (promoteKind (tyConKind tc)) buildPromotedDataCon :: DataCon -> TyCon buildPromotedDataCon dc @@ -1040,7 +1041,7 @@ promoteType ty = mkForAllTys kvs (go rho) where (tvs, rho) = splitForAllTys ty - kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ] + kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ] env = zipVarEnv tvs kvs go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys) @@ -1048,4 +1049,12 @@ promoteType ty go (TyVarTy tv) | Just kv <- lookupVarEnv env tv = TyVarTy kv go _ = panic "promoteType" -- Argument did not satisfy isPromotableType + +promoteKind :: Kind -> SuperKind +-- Promote the kind of a type constructor +-- from (* -> * -> *) to (BOX -> BOX -> BOX) +promoteKind (TyConApp tc []) + | tc `hasKey` liftedTypeKindTyConKey = superKind +promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res) +promoteKind k = pprPanic "promoteKind" (ppr k) \end{code} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 60f4cf16ae..4671b394cc 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -881,11 +881,11 @@ unsafeCoerceId `setUnfoldingInfo` mkCompulsoryUnfolding rhs - ty = mkForAllTys [argAlphaTyVar,openBetaTyVar] - (mkFunTy argAlphaTy openBetaTy) - [x] = mkTemplateLocals [argAlphaTy] - rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy) + ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] + (mkFunTy openAlphaTy openBetaTy) + [x] = mkTemplateLocals [openAlphaTy] + rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ + Cast (Var x) (mkUnsafeCo openAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -906,10 +906,12 @@ seqId = pcMiscPrelId seqName ty info `setSpecInfo` mkSpecInfo [seq_cast_rule] - ty = mkForAllTys [alphaTyVar,argBetaTyVar] - (mkFunTy alphaTy (mkFunTy argBetaTy argBetaTy)) - [x,y] = mkTemplateLocals [alphaTy, argBetaTy] - rhs = mkLams [alphaTyVar,argBetaTyVar,x,y] (Case (Var x) x argBetaTy [(DEFAULT, [], Var y)]) + ty = mkForAllTys [alphaTyVar,betaTyVar] + (mkFunTy alphaTy (mkFunTy betaTy betaTy)) + -- NB argBetaTyVar; see Note [seqId magic] + + [x,y] = mkTemplateLocals [alphaTy, betaTy] + rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) -- See Note [Built-in RULES for seq] seq_cast_rule = BuiltinRule { ru_name = fsLit "seq of cast" @@ -933,12 +935,29 @@ lazyId = pcMiscPrelId lazyIdName ty info ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) \end{code} +Note [Unsafe coerce magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a *primitive* + GHC.Prim.unsafeCoerce# +and then in the base library we define the ordinary function + Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b + unsafeCoerce x = unsafeCoerce# x + +Notice that unsafeCoerce has a civilized (albeit still dangerous) +polymorphic type, whose type args have kind *. So you can't use it on +unboxed values (unsafeCoerce 3#). + +In contrast unsafeCoerce# is even more dangerous because you *can* use +it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is + forall (a:OpenKind) (b:OpenKind). a -> b + Note [seqId magic] ~~~~~~~~~~~~~~~~~~ 'GHC.Prim.seq' is special in several ways. a) Its second arg can have an unboxed type x `seq` (v +# w) + Hence its second type variable has ArgKind b) Its fixity is set in LoadIface.ghcPrimIface diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index ea8e9d2622..af7cb35e8c 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -39,7 +39,8 @@ module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, Id, KindVar, DictId, DFunId, EvVar, EqVar, EvId, IpId, + Var, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId, + TyVar, TypeVar, KindVar, TKVar, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -54,7 +55,7 @@ module Var ( setIdExported, setIdNotExported, -- ** Predicates - isId, isTyVar, isTcTyVar, + isId, isTKVar, isTyVar, isTcTyVar, isLocalVar, isLocalId, isGlobalId, isExportedId, mustHaveLocalBinding, @@ -102,7 +103,10 @@ import Data.Data \begin{code} type Id = Var -- A term-level identifier -type TyVar = Var -- Type *or* kind variable +type TyVar = Var -- Type *or* kind variable (historical) + +type TKVar = Var -- Type *or* kind variable (historical) +type TypeVar = Var -- Definitely a type variable type KindVar = Var -- Definitely a kind variable -- See Note [Kind and type variables] @@ -136,8 +140,8 @@ Before kind polymorphism, TyVar were used to mean type variables. Now they are use to mean kind *or* type variables. KindVar is used when we know for sure that it is a kind variable. In future, we might want to go over the whole compiler code to use: - - KiTyVar to mean kind or type variables - - TyVar to mean type variables only + - TKVar to mean kind or type variables + - TypeVar to mean type variables only - KindVar to mean kind variables @@ -157,13 +161,13 @@ in its @VarDetails@. -- | Essentially a typed 'Name', that may also contain some additional information -- about the 'Var' and it's use sites. data Var - = TyVar { -- type and kind variables + = TyVar { -- Type and kind variables -- see Note [Kind and type variables] varName :: !Name, - realUnique :: FastInt, -- Key for fast comparison - -- Identical to the Unique in the name, - -- cached here for speed - varType :: Kind -- ^ The type or kind of the 'Var' in question + realUnique :: FastInt, -- Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question } | TcTyVar { -- Used only during type inference @@ -329,7 +333,7 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details } mkKindVar :: Name -> SuperKind -> KindVar -- mkKindVar take a SuperKind as argument because we don't have access --- to tySuperKind here. +-- to superKind here. mkKindVar name kind = TyVar { varName = name , realUnique = getKeyFastInt (nameUnique name) @@ -411,10 +415,13 @@ setIdNotExported id = ASSERT( isLocalId id ) %************************************************************************ \begin{code} -isTyVar :: Var -> Bool -- True of both type variables only -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False +isTyVar :: Var -> Bool +isTyVar = isTKVar -- Historical + +isTKVar :: Var -> Bool -- True of both type and kind variables +isTKVar (TyVar {}) = True +isTKVar (TcTyVar {}) = True +isTKVar _ = False isTcTyVar :: Var -> Bool isTcTyVar (TcTyVar {}) = True diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index e6d9eea6e6..27c9bcb2cf 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} +{-# LANGUAGE GADTs, NoMonoLocalBinds #-} {-# 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,8 +7,8 @@ -- for details -- Norman likes local bindings --- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds --- flag in due course +-- If this module lives on I'd like to get rid of the NoMonoLocalBinds +-- extension in due course -- Todo: remove -fno-warn-warnings-deprecations {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 1c09599156..80c6079aac 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -37,7 +37,7 @@ get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS get_conv (ForeignTarget _ fc) = Foreign fc cmm_target :: ForeignTarget -> Old.CmmCallTarget -cmm_target (PrimTarget op) = Old.CmmPrim op +cmm_target (PrimTarget op) = Old.CmmPrim op Nothing cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 885639b874..6eb91e89ba 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -217,6 +217,10 @@ filterRegsUsed p e = foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs) emptyRegSet e +instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where + foldRegsUsed f z (Just x) = foldRegsUsed f z x + foldRegsUsed _ z Nothing = z + instance UserOfLocalRegs CmmReg where foldRegsUsed f z (CmmLocal reg) = f z reg foldRegsUsed _ z (CmmGlobal _) = z diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index bed3b18b8e..98e6eb286d 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -134,7 +134,8 @@ lintCmmStmt platform labels = lint _ <- lintCmmExpr platform r return () lint (CmmCall target _res args _) = - lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args + do lintTarget platform labels target + mapM_ (lintCmmExpr platform . hintlessCmm) args lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches @@ -149,9 +150,12 @@ lintCmmStmt platform labels = lint checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: Platform -> CmmCallTarget -> CmmLint () -lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return () -lintTarget _ (CmmPrim {}) = return () +lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint () +lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e + return () +lintTarget _ _ (CmmPrim _ Nothing) = return () +lintTarget platform labels (CmmPrim _ (Just stmts)) + = mapM_ (lintCmmStmt platform labels) stmts checkCond :: Platform -> CmmExpr -> CmmLint () diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 2effa3a45f..d9484a6644 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -439,9 +439,15 @@ data CallishMachOp | MO_F32_Log | MO_F32_Exp | MO_F32_Sqrt + + | MO_S_QuotRem Width + | MO_U_QuotRem Width + | MO_Add2 Width + | MO_U_Mul2 Width + | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) - + -- Note that these three MachOps all take 1 extra parameter than the -- standard C lib versions. The extra (last) parameter contains -- alignment of the pointers. Used for optimisation in backends. diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index ae715a9eb7..e4ad450069 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -61,7 +61,8 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmStore e1 e2) = expr (expr m e1) e2 stmt m (CmmCall c _ as _) = f (actuals m as) c where f m (CmmCallee e _) = expr m e - f m (CmmPrim _) = m + f m (CmmPrim _ Nothing) = m + f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts 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 @@ -269,7 +270,7 @@ inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e inlineStmt u a (CmmCall target regs es ret) = CmmCall (infn target) regs es' ret where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p) = CmmPrim p + infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts) 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 diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 029c3323db..64b2ae410a 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -912,13 +912,13 @@ primCall results_code name args_code vols safety case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> code (emitForeignCall' PlaySafe results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) where + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where CmmInterruptible -> code (emitForeignCall' PlayInterruptible results - (CmmPrim p) args vols NoC_SRT CmmMayReturn) + (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 3d98d0a9ec..73e8b338f5 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -1,6 +1,6 @@ -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +{-# LANGUAGE NoMonoLocalBinds #-} -- Norman likes local bindings --- If this module lives on I'd like to get rid of this flag in due course +-- If this module lives on I'd like to get rid of this extension in due course module CmmPipeline ( -- | Converts C-- with an implicit stack and native C-- calls into diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index 8c4f8e3704..c7fedad05b 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -1,7 +1,7 @@ -{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} +{-# LANGUAGE GADTs, NoMonoLocalBinds #-} -- Norman likes local bindings --- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds --- flag in due course +-- If this module lives on I'd like to get rid of the NoMonoLocalBinds +-- extension in due course {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 27277540fe..59455d3b54 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -10,6 +10,7 @@ module CmmType , Width(..) , widthInBits, widthInBytes, widthInLog, widthFromBytes , wordWidth, halfWordWidth, cIntWidth, cLongWidth + , halfWordMask , narrowU, narrowS ) where @@ -163,6 +164,11 @@ halfWordWidth | wORD_SIZE == 4 = W16 | wORD_SIZE == 8 = W32 | otherwise = panic "MachOp.halfWordRep: Unknown word size" +halfWordMask :: Integer +halfWordMask | wORD_SIZE == 4 = 0xFFFF + | wORD_SIZE == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" + -- cIntRep is the Width for a C-language 'int' cIntWidth, cLongWidth :: Width #if SIZEOF_INT == 4 diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 3badef793f..b63cae5d21 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -350,7 +350,7 @@ copyOutOflow conv transfer area@(CallArea a) actuals updfr_off (setRA, init_offset) = case a of Young id -> id `seq` -- Generate a store instruction for - -- the return address if making a call + -- the return address if making a call if transfer == Call then ([(CmmLit (CmmBlock id), StackParam init_offset)], widthInBytes wordWidth) diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 7b5917d3bf..fc4706c8c4 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -222,8 +222,8 @@ instance UserOfLocalRegs CmmStmt where gen a set = foldRegsUsed f set a instance UserOfLocalRegs CmmCallTarget where - foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e - foldRegsUsed _ set (CmmPrim {}) = set + foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e + foldRegsUsed f set (CmmPrim _ mStmts) = foldRegsUsed f set mStmts instance UserOfSlots CmmCallTarget where foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e @@ -293,5 +293,8 @@ data CmmCallTarget | CmmPrim -- Call a "primitive" (eg. sin, cos) CallishMachOp -- These might be implemented as inline -- code by the backend. - deriving Eq + -- If we don't know how to implement the + -- mach op, then we can replace it with + -- this list of statements: + (Maybe [CmmStmt]) diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index 14a17d7946..0ec7a25f15 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -96,3 +96,4 @@ maybeAssignTemp uniques e | hasNoGlobalRegs e = (uniques, [], e) | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) + diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 4b1da0b242..24821b61af 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -139,7 +139,7 @@ pprStmt platform stmt = case stmt of _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. - CmmCall (CmmPrim op) results args ret -> + CmmCall (CmmPrim op _) results args ret -> pprStmt platform (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret) where diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 658e3ca5d8..9da00590c2 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -237,7 +237,10 @@ pprStmt platform stmt = case stmt of pprCall platform cast_fn cconv results args <> semi) -- for a dynamic call, no declaration is necessary. - CmmCall (CmmPrim op) results args _ret -> + CmmCall (CmmPrim _ (Just stmts)) _ _ _ -> + vcat $ map (pprStmt platform) stmts + + CmmCall (CmmPrim op _) results args _ret -> pprCall platform ppr_fn CCallConv results args' where ppr_fn = pprCallishMachOp_for_C op @@ -658,7 +661,13 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) - MO_Touch -> panic $ "pprCallishMachOp_for_C: MO_Touch not supported!" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_Touch -> unsupported + where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop + ++ " not supported!") -- --------------------------------------------------------------------- -- Useful #defines @@ -926,13 +935,19 @@ te_Lit _ = return () te_Stmt :: CmmStmt -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >> - mapM_ (te_Expr.hintlessCmm) es +te_Stmt (CmmCall target rs es _) = do te_Target target + mapM_ (te_temp.hintlessCmm) rs + mapM_ (te_Expr.hintlessCmm) es te_Stmt (CmmCondBranch e _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e te_Stmt (CmmJump e _) = te_Expr e te_Stmt _ = return () +te_Target :: CmmCallTarget -> TE () +te_Target (CmmCallee {}) = return () +te_Target (CmmPrim _ Nothing) = return () +te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts + te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit te_Expr (CmmLoad e _) = te_Expr e diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index d6537c27e5..4d1ce50099 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -485,7 +485,7 @@ emitBlackHoleCode is_single_entry = do stmtsC [ CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)), - CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmMayReturn, + CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) ] \end{code} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 09636bc6b2..16e77eca35 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -78,9 +78,11 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live where (call_args, cmm_target) = case target of + StaticTarget _ _ False -> + panic "emitForeignCall: unexpected FFI value import" -- If the packageId is Nothing then the label is taken to be in the -- package currently being compiled. - StaticTarget lbl mPkgId + StaticTarget lbl mPkgId True -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index b0865d69d9..3f1187f6be 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -33,6 +33,8 @@ import Outputable import FastString import StaticFlags +import Control.Monad + -- --------------------------------------------------------------------------- -- Code generation for PrimOps @@ -430,7 +432,7 @@ emitPrimOp [res] op args live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim prim) + (CmmPrim prim Nothing) [CmmHinted a NoHint | a<-args] -- ToDo: hints? (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky @@ -440,9 +442,114 @@ emitPrimOp [res] op args live = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt +emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ + = let genericImpl + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt +emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ + = let genericImpl + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt +emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ + = do r1 <- newLocalReg (cmmExprType arg_x) + r2 <- newLocalReg (cmmExprType arg_x) + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl + = [CmmAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + CmmAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + CmmAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) + stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt +emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ + = do let t = cmmExprType arg_x + xlyl <- liftM CmmLocal $ newLocalReg t + xlyh <- liftM CmmLocal $ newLocalReg t + xhyl <- liftM CmmLocal $ newLocalReg t + r <- liftM CmmLocal $ newLocalReg t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl + = [CmmAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + CmmAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + CmmAssign r + (sum [topHalf (CmmReg xlyl), + bottomHalf (CmmReg xhyl), + bottomHalf (CmmReg xlyh)]), + CmmAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + CmmAssign (CmmLocal res_h) + (sum [mul (topHalf arg_x) (topHalf arg_y), + topHalf (CmmReg xhyl), + topHalf (CmmReg xlyh), + topHalf (CmmReg r)])] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) + stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt + emitPrimOp _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) +newLocalReg :: CmmType -> FCode LocalReg +newLocalReg t = do u <- newUnique + return $ LocalReg u t -- These PrimOps are NOPs in Cmm @@ -889,7 +996,7 @@ emitMemcpyCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memcpy) + (CmmPrim MO_Memcpy Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -906,7 +1013,7 @@ emitMemmoveCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memmove) + (CmmPrim MO_Memmove Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -924,7 +1031,7 @@ emitMemsetCall dst c n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memset) + (CmmPrim MO_Memset Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted c NoHint) , (CmmHinted n NoHint) @@ -956,7 +1063,7 @@ emitPopCntCall res x width live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim (MO_PopCnt width)) + (CmmPrim (MO_PopCnt width) Nothing) [(CmmHinted x NoHint)] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2bd35c8796..f971a0500a 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1011,7 +1011,8 @@ fixStgRegStmt stmt CmmCall target regs args returns -> let target' = case target of CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv - other -> other + CmmPrim op mStmts -> + CmmPrim op (fmap (map fixStgRegStmt) mStmts) args' = map (\(CmmHinted arg hint) -> (CmmHinted (fixStgRegExpr arg) hint)) args in CmmCall target' regs args' returns diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index af88ba848a..c41832a0ab 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -56,7 +56,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a = do { cmm_args <- getFCallArgs stg_args ; let ((call_args, arg_hints), cmm_target) = case target of - StaticTarget lbl mPkgId + StaticTarget _ _ False -> + panic "cgForeignCall: unexpected FFI value import" + StaticTarget lbl mPkgId True -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index cbb3bd877f..369f1a308e 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -18,7 +18,7 @@ module CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars, -- * Free variables of Rules, Vars and Ids - varTypeTyVars, varTypeTcTyVars, + varTypeTyVars, idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, rulesFreeVars, @@ -406,18 +406,8 @@ delBinderFV b s = (s `delVarSet` b) `unionFVs` varTypeTyVars b -- Include coercion variables too! varTypeTyVars :: Var -> TyVarSet --- Find the type variables free in the type of the variable --- Remember, coercion variables can mention type variables... -varTypeTyVars var - | isLocalId var = tyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars - -varTypeTcTyVars :: Var -> TyVarSet --- Find the type variables free in the type of the variable --- Remember, coercion variables can mention type variables... -varTypeTcTyVars var - | isLocalId var = tcTyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyVars var = tyVarsOfType (varType var) idFreeVars :: Id -> VarSet -- Type variables, rule variables, and inline variables diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index f62d519bbb..dfc9991aa5 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -14,6 +14,10 @@ A ``lint'' pass to check for Core correctness -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details +#if __GLASGOW_HASKELL__ >= 704 +{-# OPTIONS_GHC -fprof-auto #-} +#endif + module CoreLint ( lintCoreBindings, lintUnfolding ) where #include "HsVersions.h" @@ -49,8 +53,8 @@ import Outputable import FastString import Util import Control.Monad +import MonadUtils import Data.Maybe -import Data.Traversable (traverse) \end{code} %************************************************************************ @@ -223,8 +227,15 @@ type InCoercion = Coercion type InVar = Var type InTyVar = TyVar -type OutKind = Kind -- Substitution has been applied to this -type OutType = Type -- Substitution has been applied to this +type OutKind = Kind -- Substitution has been applied to this, + -- but has not been linted yet +type LintedKind = Kind -- Substitution applied, and type is linted + +type OutType = Type -- Substitution has been applied to this, + -- but has not been linted yet + +type LintedType = Type -- Substitution applied, and type is linted + type OutCoercion = Coercion type OutVar = Var type OutTyVar = TyVar @@ -253,7 +264,7 @@ lintCoreExpr (Lit lit) lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr ; co' <- applySubstCo co - ; (from_ty, to_ty) <- lintCoercion co' + ; (_, from_ty, to_ty) <- lintCoercion co' ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) ; return to_ty } @@ -269,14 +280,14 @@ lintCoreExpr (Tick _other_tickish expr) lintCoreExpr (Let (NonRec tv (Type ty)) body) | isTyVar tv = -- See Note [Linting type lets] - do { ty' <- addLoc (RhsOf tv) $ lintInTy ty + do { ty' <- applySubstTy ty ; lintTyBndr tv $ \ tv' -> - addLoc (BodyOfLetRec [tv]) $ - extendSubstL tv' ty' $ do - { checkTyKind tv' ty' + do { addLoc (RhsOf tv) $ checkTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body - ; lintCoreExpr body } } + ; extendSubstL tv' ty' $ + addLoc (BodyOfLetRec [tv]) $ + lintCoreExpr body } } lintCoreExpr (Let (NonRec bndr rhs) body) | isId bndr @@ -297,21 +308,6 @@ lintCoreExpr (Let (Rec pairs) body) (_, dups) = removeDups compare bndrs lintCoreExpr e@(App _ _) -{- DV: This grievous hack (from ghc-constraint-solver should not be needed: - | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments - -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds, - -- we should do this properly - , Just dc <- isDataConWorkId_maybe x - , dc == eqBoxDataCon - , [Type arg_ty1, Type arg_ty2, co_e] <- args - = do arg_ty1' <- lintInTy arg_ty1 - arg_ty2' <- lintInTy arg_ty2 - unless (typeKind arg_ty1' `eqKind` typeKind arg_ty2') - (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2)) - - lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e - | otherwise --} = do { fun_ty <- lintCoreExpr fun ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } where @@ -319,9 +315,8 @@ lintCoreExpr e@(App _ _) lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ - lintBinders [var] $ \ vars' -> - do { let [var'] = vars' - ; body_ty <- lintCoreExpr expr + lintBinder var $ \ var' -> + do { body_ty <- lintCoreExpr expr ; if isId var' then return (mkFunTy (idType var') body_ty) else @@ -375,7 +370,6 @@ lintCoreExpr (Coercion co) Note [Kind instantiation in coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider the following coercion axiom: ax_co [(k_ag :: BOX), (f_aa :: k_ag -> Constraint)] :: T k_ag f_aa ~ f_aa @@ -457,7 +451,6 @@ checkTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied checkTyKind tyvar arg_ty | isSuperKind tyvar_kind -- kind forall - -- IA0_NOTE: I added this case to handle kind foralls = lintKind arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give @@ -466,33 +459,10 @@ checkTyKind tyvar arg_ty | otherwise -- type forall = do { arg_kind <- lintType arg_ty ; unless (arg_kind `isSubKind` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty)) } + (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } where tyvar_kind = tyVarKind tyvar --- Check that the kinds of a type variable and a coercion match, that --- is, if tv :: k then co :: t1 ~ t2 where t1 :: k and t2 :: k. -checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType) -checkTyCoKind tv co - = do { (t1,t2) <- lintCoercion co - -- t1,t2 have the same kind - ; unless (typeKind t1 `isSubKind` tyVarKind tv) - (addErrL (mkTyCoAppErrMsg tv co)) - ; return (t1,t2) } - -checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)] -checkTyCoKinds = zipWithM checkTyCoKind - -checkKiCoKind :: KindVar -> OutCoercion -> LintM Kind --- see lintCoercion (AxiomInstCo {}) and Note [Kind instantiation in coercions] -checkKiCoKind kv co - = do { ki <- lintKindCoercion co - ; unless (isSuperKind (tyVarKind kv)) (addErrL (mkTyCoAppErrMsg kv co)) - ; return ki } - -checkKiCoKinds :: [KindVar] -> [OutCoercion] -> LintM [Kind] -checkKiCoKinds = zipWithM checkKiCoKind - checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... -- except when we are checking a case pattern @@ -649,93 +619,54 @@ lintAndScopeId id linterF %************************************************************************ %* * -\subsection[lint-monad]{The Lint monad} + Types and kinds %* * %************************************************************************ +We have a single linter for types and kinds. That is convenient +because sometimes it's not clear whether the thing we are looking +at is a type or a kind. + \begin{code} -lintInTy :: InType -> LintM OutType +lintInTy :: InType -> LintM LintedType +-- Types only, not kinds -- Check the type, and apply the substitution to it -- See Note [Linting type lets] lintInTy ty = addLoc (InType ty) $ do { ty' <- applySubstTy ty - ; k <- lintType ty' - ; lintKind k + ; _k <- lintType ty' ; return ty' } ------------------- -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) - = do { lintKind k1; lintKind k2 } - -lintKind kind@(TyConApp tc kis) - | 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 kind - = addErrL (hang (ptext (sLit "Malformed kind:")) - 2 (quotes (ppr kind))) - -------------------- lintTyBndrKind :: OutTyVar -> LintM () -- Handles both type and kind foralls. -lintTyBndrKind tv = - let ki = tyVarKind tv in - if isSuperKind ki - 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)) +lintTyBndrKind tv = lintKind (tyVarKind tv) ------------------- -lintType :: OutType -> LintM Kind +lintType :: OutType -> LintM LintedKind -- 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) + ; return (tyVarKind tv) } + -- We checked its kind when we added it to the envt lintType ty@(AppTy t1 t2) = do { k1 <- lintType t1 - ; lint_ty_app ty k1 [t2] } + ; k2 <- lintType t2 + ; lint_ty_app ty k1 [(t2,k2)] } -lintType ty@(FunTy t1 t2) - = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2] +lintType ty@(FunTy t1 t2) -- (->) has two different rules, for types and kinds + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; lintArrow (ptext (sLit "type or kind") <+> quotes (ppr ty)) k1 k2 } lintType ty@(TyConApp tc tys) - | tyConHasKind tc -- Guards for SuperKindOon - , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc + | 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 + = do { ks <- mapM lintType tys + ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) } | otherwise = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty)) @@ -745,16 +676,42 @@ lintType (ForAllTy tv ty) lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) ----------------- -lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind +\end{code} + + +\begin{code} +lintKind :: OutKind -> LintM () +lintKind k = do { sk <- lintType k + ; unless (isSuperKind sk) + (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) + 2 (ptext (sLit "has kind:") <+> ppr sk))) } +\end{code} + + +\begin{code} +lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind +lintArrow what k1 k2 -- Eg lintArrow "type or kind `blah'" k1 k2 + -- or lintarrow "coercion `blah'" k1 k2 + | isSuperKind k1 + = return superKind + | otherwise + = do { unless (okArrowArgKind k1) (addErrL (msg (ptext (sLit "argument")) k1)) + ; unless (okArrowResultKind k2) (addErrL (msg (ptext (sLit "result")) k2)) + ; return liftedTypeKind } + where + msg ar k + = vcat [ hang (ptext (sLit "Ill-kinded") <+> ar) + 2 (ptext (sLit "in") <+> what) + , what <+> ptext (sLit "kind:") <+> ppr k ] + +lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind lint_ty_app ty k tys - = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys + = lint_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys ---------------- -lint_co_app :: Coercion -> Kind -> [OutType] -> LintM () +lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind lint_co_app ty k tys - = do { _ <- lint_kind_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys - ; return () } + = lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys ---------------- lintTyLit :: TyLit -> LintM () @@ -764,38 +721,31 @@ lintTyLit (NumTyLit n) where msg = ptext (sLit "Negative type literal:") <+> integer n lintTyLit (StrTyLit _) = return () ----------------- -lint_kind_app :: SDoc -> Kind -> [OutType] -> LintM Kind --- (lint_kind_app d fun_kind arg_tys) +lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind +-- (lint_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 +lint_app doc kfn kas + = foldlM go_app kfn kas 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 } } + , nest 2 (ptext (sLit "Arg kinds =") <+> ppr kas) ] + + go_app kfn ka + | Just kfn' <- coreView kfn + = go_app kfn' ka + + go_app (FunTy kfa kfb) (_,ka) + = do { unless (ka `isSubKind` kfa) (addErrL fail_msg) + ; return kfb } + + go_app (ForAllTy kv kfn) (ta,ka) + = do { unless (ka `isSubKind` tyVarKind kv) (addErrL fail_msg) + ; return (substKiWith [kv] [ta] kfn) } + go_app _ _ = failWithL fail_msg \end{code} %************************************************************************ @@ -814,54 +764,37 @@ lintInCo 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 - = failWithL (hang (ptext (sLit "Non-refl kind coercion")) - 2 (ppr co)) - -lintCoercion :: OutCoercion -> LintM (OutType, OutType) +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType) -- Check the kind of a coercion term, returning the kind -- Post-condition: the returned OutTypes are lint-free -- and have the same kind as each other lintCoercion (Refl ty) - = do { _ <- lintType ty - ; return (ty, ty) } + = do { k <- lintType ty + ; return (k, ty, ty) } lintCoercion co@(TyConAppCo tc cos) - = do -- We use the kind of the type constructor to know how many - -- kind coercions we have (one kind coercion for one kind - -- instantiation). - { let ki | tc `hasKey` funTyConKey && length cos == 2 - = mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind - -- It's a fully applied function, so we must use the - -- most permissive type for the arrow constructor - | otherwise = tyConKind tc - (kvs, _) = splitForAllTys ki - (cokis, cotys) = splitAt (length kvs) cos - -- kis are the kind instantiations of tc - ; kis <- mapM lintKindCoercion cokis - ; (ss,ts) <- mapAndUnzipM lintCoercion cotys - ; lint_co_app co ki (kis ++ ss) - ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) } + | tc `hasKey` funTyConKey + , [co1,co2] <- cos + = do { (k1,s1,t1) <- lintCoercion co1 + ; (k2,s2,t2) <- lintCoercion co2 + ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 + ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2) } + | otherwise + = do { (ks,ss,ts) <- mapAndUnzip3M lintCoercion cos + ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) + ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts) } lintCoercion co@(AppCo co1 co2) - = do { (s1,t1) <- lintCoercion co1 - ; (s2,t2) <- lintCoercion co2 - ; lint_co_app co (typeKind s1) [s2] - ; return (mkAppTy s1 s2, mkAppTy t1 t2) } - -lintCoercion (ForAllCo v co) - = do { let kind = tyVarKind v - -- lintKind when type forall, otherwise we are a kind forall - ; unless (isSuperKind kind) (lintKind kind) - ; (s,t) <- addInScopeVar v (lintCoercion co) - ; return (ForAllTy v s, ForAllTy v t) } + = do { (k1,s1,t1) <- lintCoercion co1 + ; (k2,s2,t2) <- lintCoercion co2 + ; rk <- lint_co_app co k1 [(s2,k2)] + ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2) } + +lintCoercion (ForAllCo tv co) + = do { lintTyBndrKind tv + ; (k, s, t) <- addInScopeVar tv (lintCoercion co) + ; return (k, mkForAllTy tv s, mkForAllTy tv t) } lintCoercion (CoVarCo cv) | not (isCoVar cv) @@ -870,58 +803,87 @@ lintCoercion (CoVarCo cv) | otherwise = do { checkTyCoVarInScope cv ; cv' <- lookupIdInScope cv - ; return (coVarKind cv') } - -lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs - , co_ax_lhs = lhs - , co_ax_rhs = rhs }) - cos) - = ASSERT2 (not (any isKiVar tvs), ppr ktvs) - do -- see Note [Kind instantiation in coercions] - { kis <- checkKiCoKinds kvs kcos - ; let tvs' = map (updateTyVarKind (Type.substTy subst)) tvs - subst = zipOpenTvSubst kvs kis - ; (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs' tcos) - ; return (substTyWith ktvs (kis ++ tys1) lhs, - substTyWith ktvs (kis ++ tys2) rhs) } - where - (kvs, tvs) = splitKiTyVars ktvs - (kcos, tcos) = splitAt (length kvs) cos + ; let (s,t) = coVarKind cv' + k = typeKind s + ; when (isSuperKind k) $ + checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) + 2 (ppr cv)) + ; return (k, s, t) } lintCoercion (UnsafeCo ty1 ty2) - = do { _ <- lintType ty1 - ; _ <- lintType ty2 - ; return (ty1, ty2) } + = do { k1 <- lintType ty1 + ; _k2 <- lintType ty2 +-- ; unless (k1 `eqKind` k2) $ +-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) +-- 2 (ppr co)) + ; return (k1, ty1, ty2) } lintCoercion (SymCo co) - = do { (ty1, ty2) <- lintCoercion co - ; return (ty2, ty1) } + = do { (k, ty1, ty2) <- lintCoercion co + ; return (k, ty2, ty1) } lintCoercion co@(TransCo co1 co2) - = do { (ty1a, ty1b) <- lintCoercion co1 - ; (ty2a, ty2b) <- lintCoercion co2 + = do { (k1, ty1a, ty1b) <- lintCoercion co1 + ; (_, ty2a, ty2b) <- lintCoercion co2 ; checkL (ty1b `eqType` ty2a) (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; return (ty1a, ty2b) } - -lintCoercion the_co@(NthCo d co) - = do { (s,t) <- lintCoercion co - ; sn <- checkTcApp the_co d s - ; tn <- checkTcApp the_co d t - ; return (sn, tn) } + ; return (k1, ty1a, ty2b) } + +lintCoercion the_co@(NthCo n co) + = do { (_,s,t) <- lintCoercion co + ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of + (Just (tc_s, tys_s), Just (tc_t, tys_t)) + | tc_s == tc_t + , tys_s `equalLength` tys_t + , n < length tys_s + -> return (ks, ts, tt) + where + ts = tys_s !! n + tt = tys_t !! n + ks = typeKind ts + + _ -> failWithL (hang (ptext (sLit "Bad getNth:")) + 2 (ppr the_co $$ ppr s $$ ppr t)) } lintCoercion (InstCo co arg_ty) - = do { co_tys <- lintCoercion co - ; arg_kind <- lintType arg_ty - ; case splitForAllTy_maybe `traverse` toPair co_tys of - Just (Pair (tv1,ty1) (tv2,ty2)) + = do { (k,s,t) <- lintCoercion co + ; arg_kind <- lintType arg_ty + ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of + (Just (tv1,ty1), Just (tv2,ty2)) | arg_kind `isSubKind` tyVarKind tv1 - -> return (substTyWith [tv1] [arg_ty] ty1, - substTyWith [tv2] [arg_ty] ty2) + -> return (k, substTyWith [tv1] [arg_ty] ty1, + substTyWith [tv2] [arg_ty] ty2) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) - Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } + _ -> failWithL (ptext (sLit "Bad argument of inst")) } + +lintCoercion co@(AxiomInstCo (CoAxiom { co_ax_tvs = ktvs + , co_ax_lhs = lhs + , co_ax_rhs = rhs }) + cos) + = do { -- See Note [Kind instantiation in coercions] + unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) + ; in_scope <- getInScope + ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv + ; (subst_l, subst_r) <- foldlM check_ki + (empty_subst, empty_subst) + (ktvs `zip` cos) + ; let lhs' = Type.substTy subst_l lhs + rhs' = Type.substTy subst_r rhs + ; return (typeKind lhs', lhs', rhs') } + where + bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) + 2 (ppr co)) + + check_ki (subst_l, subst_r) (ktv, co) + = do { (k, t1, t2) <- lintCoercion co + ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) + -- Using subst_l is ok, because subst_l and subst_r + -- must agree on kind equalities + ; unless (k `isSubKind` ktv_kind) (bad_ax (ptext (sLit "check_ki2"))) + ; return (Type.extendTvSubst subst_l ktv t1, + Type.extendTvSubst subst_r ktv t2) } \end{code} %************************************************************************ @@ -1042,6 +1004,9 @@ updateTvSubst subst' m = getTvSubst :: LintM TvSubst getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) +getInScope :: LintM InScopeSet +getInScope = LintM (\ _ subst errs -> (Just (getTvInScope subst), errs)) + applySubstTy :: InType -> LintM OutType applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } @@ -1235,14 +1200,6 @@ mkLetErr bndr rhs hang (ptext (sLit "Rhs:")) 4 (ppr rhs)] -mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc -mkTyCoAppErrMsg tyvar arg_co - = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), - hang (ptext (sLit "Type variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg coercion:")) - 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] - mkTyAppMsg :: Type -> Type -> MsgDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", @@ -1317,56 +1274,3 @@ dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) \end{code} - --------------- DEAD CODE ------------------- - -------------------- -checkCoKind :: CoVar -> OutCoercion -> LintM () --- Both args have had substitution applied -checkCoKind covar arg_co - = do { (s2,t2) <- lintCoercion arg_co - ; unless (s1 `eqType` s2 && t1 `coreEqType` t2) - (addErrL (mkCoAppErrMsg covar arg_co)) } - where - (s1,t1) = coVarKind covar - -lintCoVarKind :: OutCoVar -> LintM () --- Check the kind of a coercion binder -lintCoVarKind tv - = do { (ty1,ty2) <- lintSplitCoVar tv - ; lintEqType ty1 ty2 - - -------------------- -lintSplitCoVar :: CoVar -> LintM (Type,Type) -lintSplitCoVar cv - = case coVarKind_maybe cv of - Just ts -> return ts - Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") - , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) - -mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc -mkCoVarLetErr covar co - = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), - hang (ptext (sLit "Coercion variable:")) - 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), - hang (ptext (sLit "Arg coercion:")) - 4 (ppr co)] - -mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc -mkCoAppErrMsg covar arg_co - = vcat [ptext (sLit "Kinds don't match in coercion application:"), - hang (ptext (sLit "Coercion variable:")) - 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), - hang (ptext (sLit "Arg coercion:")) - 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] - - -mkCoAppMsg :: Type -> Coercion -> MsgDoc -mkCoAppMsg ty arg_co - = vcat [text "Illegal type application:", - hang (ptext (sLit "exp type:")) - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (ptext (sLit "arg type:")) - 4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))] - diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 930041dea4..64ef6b6e41 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -502,6 +502,81 @@ sizeExpr bOMB_OUT_SIZE top_args expr d2 -- Ignore d1 \end{code} +Note [Function application discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +I noticed that the output of the supercompiler generates a lot of code +with this form: + +""" +module Inlining where + +h1 k = k undefined undefined undefined + undefined undefined undefined + undefined undefined undefined + undefined undefined undefined + undefined undefined undefined + undefined undefined undefined + +a = h1 (\x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x) +b = h1 (\_ x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x) +c = h1 (\_ _ x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x) +d = h1 (\_ _ _ x _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x) +e = h1 (\_ _ _ _ x _ _ _ _ _ _ _ _ _ _ _ _ _ -> x) +f = h1 (\_ _ _ _ _ x _ _ _ _ _ _ _ _ _ _ _ _ -> x) +g = h1 (\_ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ _ _ -> x) +h = h1 (\_ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ _ -> x) +i = h1 (\_ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ -> x) +j = h1 (\_ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ -> x) +k = h1 (\_ _ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ -> x) +l = h1 (\_ _ _ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ -> x) +m = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ x _ _ _ _ _ -> x) +n = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ x _ _ _ _ -> x) +o = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ x _ _ _ -> x) +p = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ x _ _ -> x) +q = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ x _ -> x) +r = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ x -> x) +""" + +With GHC head the applications of h1 are not inlined, which hurts the +quality of the generated code a bit. I was wondering why h1 wasn't +getting inlined into each of "a" to "i" - after all, it has a manifest +lambda argument. + +It turns out that the code in CoreUnfold gives a fixed discount of +opt_UF_FunAppDiscount to a function argument such as "k" if it applied +to any arguments. This is enough to ensure that h1 is inlined if the number +of arguments applied to k is below a certain limit, but if many arguments are +applied to k then the fixed discount can't overcome the size of the +chain of apps, and h1 is never inlined. + +My proposed solution is to change CoreUnfold.funSize so that longer +chains of arguments being applied to a lambda-bound function give a +bigger discount. The motivation for this is that we would *generally* +expect that the lambda at the callsite has enough lambdas such that +all of the applications within the body can be beta-reduced away. This +change might lead to over eager inlining in cases like this, though: + +{{{ +h1 k = k x y z + +{-# NOINLINE g #-} +g = ... + +main = ... h1 (\x -> g x) ... +}}} + +In this case we aren't able to beta-reduce away all of the +applications in the body of h1 because the lambda at the call site +only binds 1 argument, not the 3 allowed by the type. I don't expect +this case to be particularly common, however. + +I chose the bonus to be (size - 20) so that application to 1 arg got +same bonus as the old fixed bonus (i.e. opt_UF_FunAppDiscount, which is 60). +If you have the bonus being (size - 40) then $fMonad[]_$c>>= with interesting +2nd arg doesn't inline in cryptarithm2 so we lose some deforestation, and +overall binary size hardly falls. + \begin{code} -- | Finds a nominal size of a string literal. litSize :: Literal -> Int @@ -541,13 +616,15 @@ funSize top_args fun n_val_args where some_val_args = n_val_args > 0 + -- See Note [Function application discount] arg_discount | some_val_args && fun `elem` top_args - = unitBag (fun, opt_UF_FunAppDiscount) + = unitBag (fun, opt_UF_FunAppDiscount + (size - 20)) | otherwise = emptyBag -- If the function is an argument and is applied -- to some values, give it an arg-discount - res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount + -- See Note [Function application discount] + res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount + (size - 20) | otherwise = 0 -- If the function is partially applied, show a result discount size | some_val_args = 10 * (1 + n_val_args) @@ -863,7 +940,7 @@ tryUnfolding dflags id lone_variable -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace ("Considering inlining: " ++ showSDoc (ppr id)) + = pprTrace ("Considering inlining: " ++ showSDocDump (ppr id)) (vcat [text "arg infos" <+> ppr arg_infos, text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 5d1c19bc5f..9e42290f7e 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -13,6 +13,7 @@ module MkCore ( mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreLams, mkWildCase, mkIfThenElse, mkWildValBinder, mkWildEvBinder, + sortQuantVars, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, @@ -84,7 +85,7 @@ import Outputable import FastString import UniqSupply import BasicTypes -import Util ( notNull, zipEqual ) +import Util ( notNull, zipEqual, sortLe ) import Pair import Constants @@ -101,6 +102,23 @@ infixl 4 `mkCoreApp`, `mkCoreApps` %************************************************************************ \begin{code} +sortQuantVars :: [Var] -> [Var] +-- Sort the variables (KindVars, TypeVars, and Ids) +-- into order: Kind, then Type, then Id +sortQuantVars = sortLe le + where + v1 `le` v2 = case (is_tv v1, is_tv v2) of + (True, False) -> True + (False, True) -> False + (True, True) -> + case (is_kv v1, is_kv v2) of + (True, False) -> True + (False, True) -> False + _ -> v1 <= v2 -- Same family + (False, False) -> v1 <= v2 + is_tv v = isTyVar v + is_kv v = isKindVar v + -- | Bind a binding group over an expression, using a @let@ or @case@ as -- appropriate (see "CoreSyn#let_app_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index d4a03ed67f..bc1429165a 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -138,8 +138,10 @@ make_exp (Var v) = do isLocal <- isALocal vName return $ case idDetails v of - FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _)) + FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v)) + FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) -> + panic "make_exp: FFI values not supported" FCallId (CCall (CCallSpec DynamicTarget callconv _)) -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v)) -- Constructors are always exported, so make sure to declare them diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 7487c66025..d98a4ad734 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -29,7 +29,6 @@ import Demand import DataCon import TyCon import Type -import Kind import Coercion import StaticFlags import BasicTypes @@ -312,12 +311,7 @@ pprTypedLetBinder binder pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) pprKindedTyVarBndr tyvar - = ptext (sLit "@") <+> ppr tyvar <> opt_kind - where - opt_kind -- Print the kind if not * - | isLiftedTypeKind kind = empty - | otherwise = dcolon <> pprKind kind - kind = tyVarKind tyvar + = ptext (sLit "@") <+> pprTvBndr tyvar -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index cb23075134..673ca37a3e 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -300,8 +300,8 @@ addExportFlagsAndRules target exports keep_alive rules prs -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool - is_exported | target == HscInterpreted = isExternalName - | otherwise = (`elemNameSet` exports) + is_exported | targetRetainsAllBindings target = isExternalName + | otherwise = (`elemNameSet` exports) \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 03f0f80082..8fc6bd91f3 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -156,18 +156,20 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts , abs_exports = exports, abs_ev_binds = ev_binds , abs_binds = binds }) + -- See Note [Desugaring AbsBinds] = do { bind_prs <- ds_lhs_binds binds - ; ds_binds <- dsTcEvBinds ev_binds - ; let core_bind = Rec (fromOL bind_prs) + ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs + | (lcl_id, rhs) <- fromOL bind_prs ] -- Monomorphic recursion possible, hence Rec + locals = map abe_mono exports tup_expr = mkBigCoreVarTup locals tup_ty = exprType tup_expr - poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + ; ds_binds <- dsTcEvBinds ev_binds + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ mkCoreLets ds_binds $ Let core_bind $ tup_expr - locals = map abe_mono exports ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs) @@ -180,13 +182,28 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts mkVarApps (Var poly_tup_id) (tyvars ++ dicts) ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = addIdSpecialisations global rules + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. ; return ((global', rhs) `consOL` spec_binds) } ; export_binds_s <- mapM mk_bind exports ; return ((poly_tup_id, poly_tup_rhs) `consOL` concatOL export_binds_s) } + where + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + add_inline :: Id -> Id -- tran + add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id ------------------------ makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) @@ -223,6 +240,16 @@ dictArity :: [Var] -> Arity dictArity dicts = count isId dicts \end{code} +[Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + Note [Rules and inlining] ~~~~~~~~~~~~~~~~~~~~~~~~~ Common special case: no type or dictionary abstraction @@ -745,7 +772,7 @@ dsEvTerm (EvLit l) = --------------------------------------- dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr -- This is the crucial function that moves --- from LCoercions to Coercions; see Note [TcCoercions] in Coercion +-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion -- e.g. dsTcCoercion (trans g1 g2) k -- = case g1 of EqBox g1# -> -- case g2 of EqBox g2# -> diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 06a41bcd1a..2fff5fdb56 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -98,7 +98,7 @@ dsCCall lbl args may_gc result_ty (ccall_result_ty, res_wrapper) <- boxResult result_ty uniq <- newUnique let - target = StaticTarget lbl Nothing + target = StaticTarget lbl Nothing True the_fcall = CCall (CCallSpec target CCallConv may_gc) the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index b613fbdcec..88caaef875 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -11,6 +11,8 @@ module DsForeign ( dsForeigns ) where #include "HsVersions.h" import TcRnMonad -- temp +import TypeRep + import CoreSyn import DsCCall @@ -125,8 +127,8 @@ dsFImport :: Id -> Coercion -> ForeignImport -> DsM ([Binding], SDoc, SDoc) -dsFImport id co (CImport cconv safety header spec) = do - (ids, h, c) <- dsCImport id co spec cconv safety header +dsFImport id co (CImport cconv safety mHeader spec) = do + (ids, h, c) <- dsCImport id co spec cconv safety mHeader return (ids, h, c) dsCImport :: Id @@ -134,7 +136,7 @@ dsCImport :: Id -> CImportSpec -> CCallConv -> Safety - -> FastString -- header + -> Maybe Header -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do let ty = pFst $ coercionKind co @@ -154,8 +156,8 @@ dsCImport id co (CLabel cid) cconv _ _ = do dsCImport id co (CFunction target) cconv@PrimCallConv safety _ = dsPrimCall id co (CCall (CCallSpec target cconv safety)) -dsCImport id co (CFunction target) cconv safety header - = dsFCall id co (CCall (CCallSpec target cconv safety)) header +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader dsCImport id co CWrapper cconv _ _ = dsFExportDynamic id co cconv @@ -182,9 +184,9 @@ fun_type_arg_stdcall_info _other_conv _ %************************************************************************ \begin{code} -dsFCall :: Id -> Coercion -> ForeignCall -> FastString +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) -dsFCall fn_id co fcall headerFilename = do +dsFCall fn_id co fcall mDeclHeader = do let ty = pFst $ coercionKind co (tvs, fun_ty) = tcSplitForAllTys ty @@ -205,35 +207,44 @@ dsFCall fn_id co fcall headerFilename = do (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) -> + CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> do fcall_uniq <- newUnique let wrapperName = mkFastString "ghc_wrapper_" `appendFS` mkFastString (showSDoc (ppr fcall_uniq)) `appendFS` mkFastString "_" `appendFS` cName - fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety) - c = include + fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) + c = includes $$ fun_proto <+> braces (cRet <> semi) - include - | nullFS headerFilename = empty - | otherwise = text "#include <" <> ftext headerFilename <> text ">" + includes = vcat [ text "#include <" <> ftext h <> text ">" + | Header h <- nub headers ] fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes cRet | isVoidRes = cCall | otherwise = text "return" <+> cCall - cCall = ppr cName <> parens argVals + cCall = if isFun + then ppr cName <> parens argVals + else if null arg_tys + then ppr cName + else panic "dsFCall: Unexpected arguments to FFI value import" raw_res_ty = case tcSplitIOType_maybe io_res_ty of Just (_ioTyCon, res_ty) -> res_ty Nothing -> io_res_ty isVoidRes = raw_res_ty `eqType` unitTy - cResType | isVoidRes = text "void" - | otherwise = showStgType raw_res_ty + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty pprCconv = ccallConvAttribute CApiConv - argTypes - | null arg_tys = text "void" - | otherwise = hsep $ punctuate comma - [ showStgType t <+> char 'a' <> int n - | (t, n) <- zip arg_tys [1..] ] + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType t ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' argVals = hsep $ punctuate comma [ char 'a' <> int n | (_, n) <- zip arg_tys [1..] ] @@ -667,6 +678,34 @@ showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName (typeTyCon t)) +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | TyConApp tycon _ <- t + , Just (CType mHeader cType) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, ptext (sLit "void")) + | otherwise + = pprPanic "toCType" (ppr t) + typeTyCon :: Type -> TyCon typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of Just (tc,_) -> tc diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 4105a9e56c..bef7b5da8d 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -252,8 +252,8 @@ repTyFamily :: LTyClDecl Name -> ProcessTyVarBinds TH.Dec -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyFamily (L loc (TyFamily { tcdFlavour = flavour, - tcdLName = tc, tcdTyVars = tvs, - tcdKind = opt_kind })) + tcdLName = tc, tcdTyVars = tvs, + tcdKindSig = opt_kind })) tyVarBinds = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- tyVarBinds tvs $ \bndrs -> @@ -338,25 +338,27 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis))) +repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc MkC s' <- repSafety s cis' <- conv_cimportspec cis - MkC str <- coreStringLit $ static - ++ unpackFS ch ++ " " - ++ cis' + MkC str <- coreStringLit (static ++ chStr ++ cis') dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) where conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet" conv_cimportspec CWrapper = return "wrapper" static = case cis of - CFunction (StaticTarget _ _) -> "static " + CFunction (StaticTarget _ _ _) -> "static " _ -> "" + chStr = case mch of + Nothing -> "" + Just (Header h) -> unpackFS h ++ " " repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) @@ -401,7 +403,7 @@ in_subst _ [] = False in_subst n ((n',_):ns) = n==n' || in_subst n ns mkGadtCtxt :: [Name] -- Tyvars of the data type - -> ResType Name + -> ResType (LHsType Name) -> DsM (HsContext Name, [(Name,Name)]) -- Given a data type in GADT syntax, figure out the equality -- context, so that we can represent it with an explicit @@ -605,7 +607,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) repTyVarBndrWithKind (L _ (UserTyVar {})) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki _)) nm +repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _) _)) nm = repKind ki >>= repKindedTV nm -- represent a type context diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3bb2f5cfc4..20a2e47a6b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -67,9 +67,9 @@ Library if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, process >= 1 && < 1.2, - bytestring >= 0.9 && < 0.10, + bytestring >= 0.9 && < 0.11, time < 1.5, - containers >= 0.1 && < 0.5, + containers >= 0.1 && < 0.6, array >= 0.1 && < 0.5 Build-Depends: filepath >= 1 && < 1.4 @@ -356,7 +356,6 @@ Library RnEnv RnExpr RnHsDoc - RnHsSyn RnNames RnPat RnSource @@ -527,7 +526,6 @@ Library SPARC.CodeGen SPARC.CodeGen.Amode SPARC.CodeGen.Base - SPARC.CodeGen.CCall SPARC.CodeGen.CondCode SPARC.CodeGen.Gen32 SPARC.CodeGen.Gen64 diff --git a/compiler/ghc.mk b/compiler/ghc.mk index e305b36a8e..014094c1d5 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -1,6 +1,6 @@ # ----------------------------------------------------------------------------- # -# (c) 2009 The University of Glasgow +# (c) 2009-2012 The University of Glasgow # # This file is part of the GHC build system. # @@ -137,9 +137,6 @@ else endif @echo done. -# XXX 2010-08-19: This is a legacy clean. Remove later. -$(eval $(call clean-target,compiler,config_hs,compiler/main/Config.hs)) - # ----------------------------------------------------------------------------- # Create platform includes @@ -360,7 +357,7 @@ compiler/main/DriverPipeline_HC_OPTS += -auto-all compiler/main/GhcMake_HC_OPTS += -auto-all compiler/main/GHC_HC_OPTS += -auto-all -# or alternatively addd {-# OPTIONS_GHC -auto-all #-} to the top of +# or alternatively add {-# OPTIONS_GHC -auto-all #-} to the top of # modules you're interested in. # We seem to still build the vanilla libraries even if we say diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index afc51163e3..046d6ec132 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -986,7 +986,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") - StaticTarget target _ + StaticTarget _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget target _ True -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) return (True, res) where diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 2dd1d11ea6..c1d5ed3ca6 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -6,6 +6,13 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +#ifndef GHCI_TABLES_NEXT_TO_CODE +{-# OPTIONS_GHC -Wwarn #-} +-- There are lots of warnings when GHCI_TABLES_NEXT_TO_CODE is off. +-- It would be nice to fix this properly, but for now we turn -Werror +-- off. +#endif + module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls , StgInfoTable(..) ) where diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5318c5be49..4bff46c853 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -161,13 +161,16 @@ cvtDec (PragmaD prag) cvtDec (TySynD tc tvs rhs) = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs - ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } + ; returnL $ TyClD (TySynonym { tcdLName = tc' + , tcdTyVars = tvs', tcdTyPats = Nothing + , tcdSynRhs = rhs', tcdFVs = placeHolderNames }) } cvtDec (DataD ctxt tc tvs constrs derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + ; returnL $ TyClD (TyData { tcdND = DataType, tcdCType = Nothing + , tcdLName = tc', tcdCtxt = ctxt' , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing , tcdCons = cons', tcdDerivs = derivs' }) } @@ -175,7 +178,8 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + ; returnL $ TyClD (TyData { tcdND = NewType, tcdCType = Nothing + , tcdLName = tc', tcdCtxt = ctxt' , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing , tcdCons = [con'], tcdDerivs = derivs'}) } @@ -214,7 +218,8 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs ; returnL $ InstD $ FamInstDecl $ - TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt' + TyData { tcdND = DataType, tcdCType = Nothing + , tcdLName = tc', tcdCtxt = ctxt' , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing , tcdCons = cons', tcdDerivs = derivs' } } @@ -223,7 +228,8 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs ; returnL $ InstD $ FamInstDecl $ - TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt' + TyData { tcdND = NewType, tcdCType = Nothing + , tcdLName = tc', tcdCtxt = ctxt' , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing , tcdCons = [con'], tcdDerivs = derivs' } } @@ -231,7 +237,9 @@ cvtDec (TySynInstD tc tys rhs) = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys ; rhs' <- cvtType rhs ; returnL $ InstD $ FamInstDecl $ - TySynonym tc' tvs' tys' rhs' } + TySynonym { tcdLName = tc' + , tcdTyVars = tvs', tcdTyPats = tys' + , tcdSynRhs = rhs', tcdFVs = placeHolderNames } } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] @@ -749,9 +757,10 @@ cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } + ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } -cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t + ; return $ SigPatIn p' (HsBSig t' placeHolderBndrs) } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) @@ -787,8 +796,7 @@ cvt_tv (TH.PlainTV nm) cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' placeHolderKind - } + ; returnL $ KindedTyVar nm' (HsBSig ki' placeHolderBndrs) placeHolderKind } cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index bb8b337a00..f756578e2d 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -175,12 +175,12 @@ data HsBindLR idL idR -- of this last construct.) data ABExport id - = ABE { abe_poly :: id + = ABE { abe_poly :: id -- Any INLINE pragmas is attached to this Id , abe_mono :: id - , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] + , abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags } - deriving (Data, Typeable) + , abe_prags :: TcSpecPrags -- SPECIALISE pragmas + } deriving (Data, Typeable) placeHolderNames :: NameSet -- Used for the NameSet in FunBind and PatBind prior to the renamer diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index e6d369c519..26d49f726c 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -449,10 +449,10 @@ data TyClDecl name | -- | @type/data family T :: *->*@ - TyFamily { tcdFlavour:: FamilyFlavour, -- type or data - tcdLName :: Located name, -- type constructor - tcdTyVars :: [LHsTyVarBndr name], -- type variables - tcdKind :: Maybe (LHsKind name) -- result kind + TyFamily { tcdFlavour :: FamilyFlavour, -- type or data + tcdLName :: Located name, -- type constructor + tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdKindSig :: Maybe (LHsKind name) -- result kind } @@ -465,6 +465,7 @@ data TyClDecl name tcdCtxt :: LHsContext name, -- ^ Context tcdLName :: Located name, -- ^ Type constructor + tcdCType :: Maybe CType, tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns. -- See Note [tcdTyVars and tcdTyPats] @@ -500,7 +501,9 @@ data TyClDecl name tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns -- See Note [tcdTyVars and tcdTyPats] - tcdSynRhs :: LHsType name -- ^ synonym expansion + tcdSynRhs :: LHsType name, -- ^ synonym expansion + tcdFVs :: NameSet -- ^ Free tycons of the decl + -- (Used for cycle detection) } | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... @@ -633,7 +636,7 @@ instance OutputableBndr name = hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon] ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon, - tcdTyVars = tyvars, tcdKind = mb_kind}) + tcdTyVars = tyvars, tcdKindSig = mb_kind}) = pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind where pp_flavour = case flavour of @@ -765,7 +768,7 @@ data ConDecl name , con_details :: HsConDeclDetails name -- ^ The main payload - , con_res :: ResType name + , con_res :: ResType (LHsType name) -- ^ Result type of the constructor , con_doc :: Maybe LHsDocString @@ -785,16 +788,16 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map cd_fld_type flds -data ResType name +data ResType ty = ResTyH98 -- Constructor was declared using Haskell 98 syntax - | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, - -- and here is its result type + | ResTyGADT ty -- Constructor was declared using GADT-style syntax, + -- and here is its result type deriving (Data, Typeable) -instance OutputableBndr name => Outputable (ResType name) where +instance Outputable ty => Outputable (ResType ty) where -- Debugging only - ppr ResTyH98 = ptext (sLit "ResTyH98") - ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty) + ppr ResTyH98 = ptext (sLit "ResTyH98") + ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> ppr ty \end{code} @@ -983,7 +986,7 @@ data ForeignImport = -- import of a C entity -- CImport CCallConv -- ccall or stdcall Safety -- interruptible, safe or unsafe - FastString -- name of C header + (Maybe Header) -- name of C header CImportSpec -- details of the C entity deriving (Data, Typeable) @@ -1013,16 +1016,21 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where 2 (dcolon <+> ppr ty) instance Outputable ForeignImport where - ppr (CImport cconv safety header spec) = + ppr (CImport cconv safety mHeader spec) = ppr cconv <+> ppr safety <+> char '"' <> pprCEntity spec <> char '"' where - pp_hdr = if nullFS header then empty else ftext header + pp_hdr = case mHeader of + Nothing -> empty + Just (Header header) -> ftext header pprCEntity (CLabel lbl) = ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget lbl _)) = - ptext (sLit "static") <+> pp_hdr <+> ppr lbl + pprCEntity (CFunction (StaticTarget lbl _ isFun)) = + ptext (sLit "static") + <+> pp_hdr + <+> (if isFun then empty else ptext (sLit "value")) + <+> ppr lbl pprCEntity (CFunction (DynamicTarget)) = ptext (sLit "dynamic") pprCEntity (CWrapper) = ptext (sLit "wrapper") @@ -1055,10 +1063,10 @@ data RuleDecl name data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (LHsType name) + | RuleBndrSig (Located name) (HsBndrSig (LHsType name)) deriving (Data, Typeable) -collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name] +collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecl name) where diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 1dd3c83f31..08d1281f13 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -473,7 +473,7 @@ ppr_expr (ExplicitList _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + = paBrackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon con_id _ rbinds) = hang (ppr con_id) 2 (ppr rbinds) @@ -489,7 +489,7 @@ ppr_expr (ExprWithTySigOut expr sig) 4 (ppr sig) ppr_expr (ArithSeq _ info) = brackets (ppr info) -ppr_expr (PArrSeq _ info) = pa_brackets (ppr info) +ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e @@ -554,11 +554,6 @@ pprCmdArg (HsCmdTop cmd _ _ _) instance OutputableBndr id => Outputable (HsCmdTop id) where ppr = pprCmdArg - --- add parallel array brackets around a document --- -pa_brackets :: SDoc -> SDoc -pa_brackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} HsSyn records exactly where the user put parens, with HsPar. @@ -1132,7 +1127,7 @@ pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts pprDo ListComp stmts = brackets $ pprComp stmts -pprDo PArrComp stmts = pa_brackets $ pprComp stmts +pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 3180d24152..1a5e206a54 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -132,7 +132,7 @@ data Pat id ------------ Pattern type signatures --------------- | SigPatIn (LPat id) -- Pattern with a type signature - (LHsType id) + (HsBndrSig (LHsType id)) | SigPatOut (LPat id) -- Pattern with a type signature Type @@ -246,7 +246,7 @@ pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) -pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) +pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) pprPat (ConPatIn con details) = pprUserCon con details @@ -292,11 +292,6 @@ instance (OutputableBndr id, Outputable arg) ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, hsRecPun = pun }) = ppr f <+> (ppUnless pun $ equals <+> ppr arg) - --- add parallel array brackets around a document --- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index a999c238a5..bd8ffa0d1c 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -17,7 +17,7 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, - HsTyVarBndr(..), LHsTyVarBndr, + HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr, HsTupleSort(..), HsExplicitFlag(..), HsContext, LHsContext, HsQuasiQuote(..), @@ -30,7 +30,7 @@ module HsTypes ( ConDeclField(..), pprConDeclFields, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, - hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName, + hsTyVarName, hsTyVarNames, hsTyVarKind, hsLTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, @@ -38,6 +38,7 @@ module HsTypes ( splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, splitHsAppTys, mkHsAppTys, mkHsOpTy, + placeHolderBndrs, -- Printing pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, @@ -48,6 +49,7 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import HsLit import NameSet( FreeVars ) +import Name( Name ) import Type import HsDoc import BasicTypes @@ -120,12 +122,44 @@ type LHsType name = Located (HsType name) type HsKind name = HsType name type LHsKind name = Located (HsKind name) +type LHsTyVarBndr name = Located (HsTyVarBndr name) + +data HsBndrSig sig + = HsBSig + sig + [Name] -- The *binding* type/kind names of this signature + deriving (Data, Typeable) +-- Consider a binder (or pattern) decoarated with a type or kind, +-- \ (x :: a -> a). blah +-- forall (a :: k -> *) (b :: k). blah +-- Then we use a LHsBndrSig on the binder, so that the +-- renamer can decorate it with the variables bound +-- by the pattern ('a' in the first example, 'k' in the second), +-- assuming that neither of them is in scope already + +placeHolderBndrs :: [Name] +-- Used for the NameSet in FunBind and PatBind prior to the renamer +placeHolderBndrs = panic "placeHolderBndrs" + +data HsTyVarBndr name + = UserTyVar -- No explicit kinding + name -- See Note [Printing KindedTyVars] + PostTcKind + + | KindedTyVar + name + (HsBndrSig (LHsKind name)) -- The user-supplied kind signature + PostTcKind + -- *** NOTA BENE *** A "monotype" in a pragma can have + -- for-alls in it, (mostly to do with dictionaries). These + -- must be explicitly Kinded. + deriving (Data, Typeable) + data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can -- print it as the user wrote it - [LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list - -- until the renamer fills in the variables + [LHsTyVarBndr name] -- See Note [HsForAllTy tyvar binders] (LHsContext name) (LHsType name) @@ -204,6 +238,22 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 \end{code} +Note [HsForAllTy tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After parsing: + * Implicit => empty + Explicit => the varibles the user wrote + +After renaming + * Implicit => the *type* variables free in the type + Explicit => the variables the user wrote (renamed) + +Note that in neither case do we inclde the kind variables. +In the explicit case, the [HsTyVarBndr] can bring kind variables +into scope: f :: forall (a::k->*) (b::k). a b -> Int +but we do not record them explicitly, similar to the case +for the type variables in a pattern type signature. + Note [Unit tuples] ~~~~~~~~~~~~~~~~~~ Consider the type @@ -332,22 +382,6 @@ hsExplicitTvs (L _ (HsForAllTy Explicit tvs _ _)) = hsLTyVarNames tvs hsExplicitTvs _ = [] --------------------- -type LHsTyVarBndr name = Located (HsTyVarBndr name) - -data HsTyVarBndr name - = UserTyVar -- No explicit kinding - name -- See Note [Printing KindedTyVars] - PostTcKind - - | KindedTyVar - name - (LHsKind name) -- The user-supplied kind signature - PostTcKind - -- *** NOTA BENE *** A "monotype" in a pragma can have - -- for-alls in it, (mostly to do with dictionaries). These - -- must be explicitly Kinded. - deriving (Data, Typeable) - hsTyVarName :: HsTyVarBndr name -> name hsTyVarName (UserTyVar n _) = n hsTyVarName (KindedTyVar n _ _) = n @@ -377,19 +411,6 @@ hsLTyVarLocName = fmap hsTyVarName hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] hsLTyVarLocNames = map hsLTyVarLocName - -replaceTyVarName :: (Monad m) => HsTyVarBndr name1 -> name2 -- new type name - -> (LHsKind name1 -> m (LHsKind name2)) -- kind renaming - -> m (HsTyVarBndr name2) -replaceTyVarName (UserTyVar _ k) n' _ = return $ UserTyVar n' k -replaceTyVarName (KindedTyVar _ k tck) n' rn = do - k' <- rn k - return $ KindedTyVar n' k' tck - -replaceLTyVarName :: (Monad m) => LHsTyVarBndr name1 -> name2 - -> (LHsKind name1 -> m (LHsKind name2)) - -> m (LHsTyVarBndr name2) -replaceLTyVarName (L loc n1) n2 rn = replaceTyVarName n1 n2 rn >>= return . L loc \end{code} @@ -477,6 +498,9 @@ splitHsFunType other = ([], other) instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty +instance (Outputable sig) => Outputable (HsBndrSig sig) where + ppr (HsBSig ty _) = ppr ty + instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name _) = ppr name ppr (KindedTyVar name kind _) = parens $ hsep [ppr name, dcolon, ppr kind] @@ -569,7 +593,7 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) _ -> BoxedTuple ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind) ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty @@ -625,10 +649,6 @@ ppr_fun_ty ctxt_prec ty1 ty2 sep [p1, ptext (sLit "->") <+> p2] -------------------------- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") - --------------------------- ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy i) = integer i ppr_tylit (HsStrTy s) = text (show s) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 293f5b05a6..f7a1a10a5b 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -761,17 +761,17 @@ lPatImplicits = hs_lpat %************************************************************************ \begin{code} -collectSigTysFromPats :: [InPat name] -> [LHsType name] +collectSigTysFromPats :: [InPat name] -> [HsBndrSig (LHsType name)] collectSigTysFromPats pats = foldr collect_sig_lpat [] pats -collectSigTysFromPat :: InPat name -> [LHsType name] +collectSigTysFromPat :: InPat name -> [HsBndrSig (LHsType name)] collectSigTysFromPat pat = collect_sig_lpat pat [] -collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name] +collect_sig_lpat :: InPat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)] collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc -collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name] -collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) +collect_sig_pat :: Pat name -> [HsBndrSig (LHsType name)] -> [HsBndrSig (LHsType name)] +collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 8bf6594df5..eff699fd6b 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -998,33 +998,10 @@ instance Binary IfaceType where putByte bh 3 put_ bh ag put_ bh ah - - -- Simple compression for common cases of TyConApp - put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6 - put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7 - put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8 - put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty } - -- Unit tuple and pairs - put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10 - put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) - = do { putByte bh 11; put_ bh t1; put_ bh t2 } - -- Kind cases - put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12 - put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13 - put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 - put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 - put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 - put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 17 - put_ bh (IfaceTyConApp IfaceSuperKindTc []) = putByte bh 18 - put_ bh (IfaceCoConApp cc tys) - = do { putByte bh 19; put_ bh cc; put_ bh tys } - - -- Generic cases - put_ bh (IfaceTyConApp (IfaceTc tc) tys) - = do { putByte bh 20; put_ bh tc; put_ bh tys } + = do { putByte bh 4; put_ bh cc; put_ bh tys } put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 21; put_ bh tc; put_ bh tys } + = do { putByte bh 5; put_ bh tc; put_ bh tys } put_ bh (IfaceLitTy n) = do { putByte bh 30; put_ bh n } @@ -1044,30 +1021,10 @@ instance Binary IfaceType where 3 -> do ag <- get bh ah <- get bh return (IfaceFunTy ag ah) - - -- Now the special cases for TyConApp - 6 -> return (IfaceTyConApp IfaceIntTc []) - 7 -> return (IfaceTyConApp IfaceCharTc []) - 8 -> return (IfaceTyConApp IfaceBoolTc []) - 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) } - 10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) - 11 -> do { t1 <- get bh; t2 <- get bh - ; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) } - 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc []) - 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc []) - 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) - 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) - 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) - 17 -> return (IfaceTyConApp IfaceConstraintKindTc []) - 18 -> return (IfaceTyConApp IfaceSuperKindTc []) - - 19 -> do { cc <- get bh; tys <- get bh - ; return (IfaceCoConApp cc tys) } - - 20 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp (IfaceTc tc) tys) } - 21 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp tc tys) } + 4 -> do { cc <- get bh; tys <- get bh + ; return (IfaceCoConApp cc tys) } + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } 30 -> do n <- get bh return (IfaceLitTy n) @@ -1088,42 +1045,8 @@ instance Binary IfaceTyLit where _ -> panic ("get IfaceTyLit " ++ show tag) instance Binary IfaceTyCon where - -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 - put_ bh IfaceBoolTc = putByte bh 2 - put_ bh IfaceCharTc = putByte bh 3 - put_ bh IfaceListTc = putByte bh 4 - put_ bh IfacePArrTc = putByte bh 5 - put_ bh IfaceLiftedTypeKindTc = putByte bh 6 - put_ bh IfaceOpenTypeKindTc = putByte bh 7 - put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 - put_ bh IfaceUbxTupleKindTc = putByte bh 9 - put_ bh IfaceArgTypeKindTc = putByte bh 10 - put_ bh IfaceConstraintKindTc = putByte bh 11 - put_ bh IfaceSuperKindTc = putByte bh 12 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 13; put_ bh bx; put_ bh ar } - put_ bh (IfaceTc ext) = do { putByte bh 14; put_ bh ext } - put_ bh (IfaceIPTc n) = do { putByte bh 15; put_ bh n } - - get bh = do - h <- getByte bh - case h of - 1 -> return IfaceIntTc - 2 -> return IfaceBoolTc - 3 -> return IfaceCharTc - 4 -> return IfaceListTc - 5 -> return IfacePArrTc - 6 -> return IfaceLiftedTypeKindTc - 7 -> return IfaceOpenTypeKindTc - 8 -> return IfaceUnliftedTypeKindTc - 9 -> return IfaceUbxTupleKindTc - 10 -> return IfaceArgTypeKindTc - 11 -> return IfaceConstraintKindTc - 12 -> return IfaceSuperKindTc - 13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } - 14 -> do { ext <- get bh; return (IfaceTc ext) } - 15 -> do { n <- get bh; return (IfaceIPTc n) } - _ -> panic ("get IfaceTyCon " ++ show h) + put_ bh (IfaceTc ext) = put_ bh ext + get bh = liftM IfaceTc (get bh) instance Binary IfaceCoCon where put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } @@ -1390,7 +1313,7 @@ instance Binary IfaceDecl where put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do putByte bh 2 put_ bh (occNameFS a1) put_ bh a2 @@ -1399,6 +1322,7 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 + put_ bh a8 put_ bh (IfaceSyn a1 a2 a3 a4) = do putByte bh 3 @@ -1441,8 +1365,9 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh + a8 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7) + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) 3 -> do a1 <- get bh a2 <- get bh a3 <- get bh diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 75b8d91881..4a93a2bbe4 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -29,6 +29,7 @@ import DataCon import Var import VarSet import BasicTypes +import ForeignCall import Name import MkId import Class @@ -56,6 +57,7 @@ buildSynTyCon tc_name tvs rhs rhs_kind parent ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables and type variables + -> Maybe CType -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag @@ -63,8 +65,8 @@ buildAlgTyCon :: Name -> TyConParent -> 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 +buildAlgTyCon tc_name ktvs cType stupid_theta rhs is_rec gadt_syn parent + = mkAlgTyCon tc_name kind ktvs cType stupid_theta rhs parent is_rec gadt_syn where kind = mkPiKinds ktvs liftedTypeKind diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index 5e4a7092bf..0365be7338 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -10,6 +10,7 @@ import Binary import BinIface () import DynFlags import HscTypes +import Module import Name import Fingerprint -- import Outputable @@ -21,11 +22,12 @@ import System.FilePath (normalise) -- | Produce a fingerprint of a @DynFlags@ value. We only base -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. -fingerprintDynFlags :: DynFlags -> (BinHandle -> Name -> IO ()) +fingerprintDynFlags :: DynFlags -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint -fingerprintDynFlags DynFlags{..} nameio = - let mainis = (mainModIs, mainFunIs) +fingerprintDynFlags DynFlags{..} this_mod nameio = + let mainis = if mainModIs == this_mod then Just mainFunIs else Nothing + -- see #5878 -- pkgopts = (thisPackage dflags, sort $ packageFlags dflags) safeHs = setSafeMode safeHaskell -- oflags = sort $ filter filterOFlags $ flags dflags @@ -38,12 +40,8 @@ fingerprintDynFlags DynFlags{..} nameio = cpp = (map normalise includePaths, sOpt_P settings) -- normalise: eliminate spurious differences due to "./foo" vs "foo" - -- -i, -osuf, -hcsuf, -hisuf, -odir, -hidir, -stubdir, -o, -ohi - paths = (map normalise importPaths, - [ objectSuf, hcSuf, hiSuf ], - [ objectDir, hiDir, stubDir, outputHi ]) - -- NB. not outputFile, we don't want "ghc --make M -o <file>" - -- to force recompilation when <file> changes. + -- Note [path flags and recompilation] + paths = [ hcSuf ] -- -fprof-auto etc. prof = if opt_SccProfilingOn then fromEnum profAuto else 0 @@ -51,3 +49,33 @@ fingerprintDynFlags DynFlags{..} nameio = in -- pprTrace "flags" (ppr (mainis, safeHs, lang, cpp, paths)) $ computeFingerprint nameio (mainis, safeHs, lang, cpp, paths, prof) + +{- Note [path flags and recompilation] + +There are several flags that we deliberately omit from the +recompilation check; here we explain why. + +-osuf, -odir, -hisuf, -hidir + If GHC decides that it does not need to recompile, then + it must have found an up-to-date .hi file and .o file. + There is no point recording these flags - the user must + have passed the correct ones. Indeed, the user may + have compiled the source file in one-shot mode using + -o to specify the .o file, and then loaded it in GHCi + using -odir. + +-stubdir + We omit this one because it is automatically set by -outputdir, and + we don't want changes in -outputdir to automatically trigger + recompilation. This could be wrong, but only in very rare cases. + +-i (importPaths) + For the same reason as -osuf etc. above: if GHC decides not to + recompile, then it must have already checked all the .hi files on + which the current module depends, so it must have found them + successfully. It is occasionally useful to be able to cd to a + different directory and use -i flags to enable GHC to find the .hi + files; we don't want this to force recompilation. + +The only path-related flag left is -hcsuf. +-} diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index ef74b13489..d3e44fe54f 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -68,6 +68,7 @@ data IfaceDecl ifIdInfo :: IfaceIdInfo } | IfaceData { ifName :: OccName, -- Type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info @@ -453,7 +454,8 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, +pprIfaceDecl (IfaceSyn {ifName = tycon, + ifTyVars = tyvars, ifSynRhs = Just mono_ty}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty]) @@ -463,11 +465,12 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) -pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, +pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, + ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifAxiom = mbAxiom}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pp_condecls tycon condecls, + 4 (vcat [pprCType cType, pprRec isrec, pp_condecls tycon condecls, pprAxiom mbAxiom]) where pp_nd = case condecls of @@ -489,6 +492,10 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyVars = tyvars, = hang (ptext (sLit "axiom") <+> ppr name <+> ppr tyvars) 2 (dcolon <+> ppr lhs <+> text "~#" <+> ppr rhs) +pprCType :: Maybe CType -> SDoc +pprCType Nothing = ptext (sLit "No C type associated") +pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType + pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec @@ -876,7 +883,6 @@ freeNamesIfExpr _ = emptyNameSet freeNamesIfTc :: IfaceTyCon -> NameSet freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? -freeNamesIfTc _ = emptyNameSet freeNamesIfCo :: IfaceCoCon -> NameSet freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 77f4b700d2..a833d2c218 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -19,7 +19,6 @@ module IfaceType ( IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..), IfaceTyLit(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, - ifaceTyConName, -- Conversion from Type -> IfaceType toIfaceType, toIfaceKind, toIfaceContext, @@ -93,20 +92,9 @@ data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString -data IfaceTyCon -- Encodes type constructors, kind constructors - -- coercion constructors, the lot - = IfaceTc IfExtName -- The common case - | IfaceIntTc | IfaceBoolTc | IfaceCharTc - | IfaceListTc | IfacePArrTc - | IfaceTupTc TupleSort Arity - | IfaceIPTc IfIPName -- Used for implicit parameter TyCons - - -- Kind constructors - | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc - | IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc - - -- SuperKind constructor - | IfaceSuperKindTc -- IA0_NOTE: You might want to check if I didn't forget something. +-- Encodes type constructors, kind constructors +-- coercion constructors, the lot +newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName } -- Coercion constructors data IfaceCoCon @@ -115,40 +103,8 @@ data IfaceCoCon | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo | IfaceTransCo | IfaceInstCo | IfaceNthCo Int - -ifaceTyConName :: IfaceTyCon -> Name -ifaceTyConName IfaceIntTc = intTyConName -ifaceTyConName IfaceBoolTc = boolTyConName -ifaceTyConName IfaceCharTc = charTyConName -ifaceTyConName IfaceListTc = listTyConName -ifaceTyConName IfacePArrTc = parrTyConName -ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) -ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName -ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName -ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName -ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName -ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName -ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName -ifaceTyConName IfaceSuperKindTc = tySuperKindTyConName -ifaceTyConName (IfaceTc ext) = ext -ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n) - -- Note [The Name of an IfaceAnyTc] \end{code} -Note [The Name of an IfaceAnyTc] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IA0_NOTE: This is an old comment. It needs to be updated with IPTc which -I don't know about. - -It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you -really need to do is to transform it to a TyCon, and get the Name of that. -But doing so needs the monad because there's an IfaceKind inside, and we -need a Kind. - -In fact, ifaceTyConName is only used for instances and rules, and we don't -expect to instantiate those at these (internal-ish) Any types, so rather -than solve this potential problem now, I'm going to defer it until it happens! - %************************************************************************ %* * Functions over IFaceTypes @@ -220,9 +176,10 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty] pprIfaceTvBndr :: IfaceTvBndr -> SDoc -pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc []) - = ppr tv +pprIfaceTvBndr (tv, IfaceTyConApp tc []) + | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) + pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars) \end{code} @@ -288,27 +245,25 @@ pprIfaceForAllPart tvs ctxt doc ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc ppr_tc_app _ tc [] = ppr_tc tc -ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty) -ppr_tc_app _ IfaceListTc _ = panic "ppr_tc_app IfaceListTc" - -ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty) -ppr_tc_app _ IfacePArrTc _ = panic "ppr_tc_app IfacePArrTc" - -ppr_tc_app _ (IfaceTupTc sort _) tys = - tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) - -ppr_tc_app _ (IfaceIPTc n) [ty] = - parens (ppr n <> dcolon <> pprIfaceType ty) -ppr_tc_app _ (IfaceIPTc _) _ = panic "ppr_tc_app IfaceIPTc" +ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty) +ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = paBrackets (pprIfaceType ty) +ppr_tc_app _ (IfaceTc n) tys + | Just (ATyCon tc) <- wiredInNameTyThing_maybe n + , Just sort <- tyConTuple_maybe tc + , tyConArity tc == length tys + = tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) + | Just (ATyCon tc) <- wiredInNameTyThing_maybe n + , Just ip <- tyConIP_maybe tc + , [ty] <- tys + = parens (ppr ip <> dcolon <> pprIfaceType ty) ppr_tc_app ctxt_prec tc tys - = maybeParen ctxt_prec tYCON_PREC + = maybeParen ctxt_prec tYCON_PREC (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))]) ppr_tc :: IfaceTyCon -> SDoc -- Wrap infix type constructors in parens -ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc) -ppr_tc tc = ppr tc +ppr_tc tc = parenSymOcc (getOccName (ifaceTyConName tc)) (ppr tc) ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n @@ -316,8 +271,7 @@ ppr_tylit (IfaceStrTyLit n) = text (show n) ------------------- instance Outputable IfaceTyCon where - ppr (IfaceIPTc n) = ppr (IPName n) - ppr other_tc = ppr (ifaceTyConName other_tc) + ppr = ppr . ifaceTyConName instance Outputable IfaceCoCon where ppr (IfaceCoAx n) = ppr n @@ -341,10 +295,6 @@ pprIfaceContext theta = ppr_preds theta <+> darrow ppr_preds :: [IfacePredType] -> SDoc ppr_preds [pred] = ppr pred -- No parens ppr_preds preds = parens (sep (punctuate comma (map ppr preds))) - -------------------- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]") \end{code} %************************************************************************ @@ -388,35 +338,10 @@ toIfaceCoVar = occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon -toIfaceTyCon tc - | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) - | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) - | otherwise = toIfaceTyCon_name (tyConName tc) +toIfaceTyCon = toIfaceTyCon_name . tyConName toIfaceTyCon_name :: Name -> IfaceTyCon -toIfaceTyCon_name nm - | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm - = toIfaceWiredInTyCon tc nm - | otherwise - = IfaceTc nm - -toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon -toIfaceWiredInTyCon tc nm - | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc) - | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n) - | nm == intTyConName = IfaceIntTc - | nm == boolTyConName = IfaceBoolTc - | nm == charTyConName = IfaceCharTc - | nm == listTyConName = IfaceListTc - | nm == parrTyConName = IfacePArrTc - | nm == liftedTypeKindTyConName = IfaceLiftedTypeKindTc - | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc - | nm == openTypeKindTyConName = IfaceOpenTypeKindTc - | nm == argTypeKindTyConName = IfaceArgTypeKindTc - | nm == constraintKindTyConName = IfaceConstraintKindTc - | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc - | nm == tySuperKindTyConName = IfaceSuperKindTc - | otherwise = IfaceTc nm +toIfaceTyCon_name = IfaceTc toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 9904042fe0..877de44330 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -19,6 +19,7 @@ module MkIface ( checkOldIface, -- See if recompilation is required, by -- comparing version information + RecompileRequired(..), recompileRequired, tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -110,6 +111,7 @@ import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.IORef +import System.Directory import System.FilePath \end{code} @@ -287,7 +289,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_fixities = fixities, mi_warns = warns, mi_anns = mkIfaceAnnotations anns, - mi_globals = Just rdr_env, + mi_globals = maybeGlobalRdrEnv rdr_env, -- Left out deliberately: filled in by addFingerprints mi_iface_hash = fingerprint0, @@ -344,7 +346,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- correctly. This stems from the fact that the interface had -- not changed, so addFingerprints returns the old ModIface -- with the old GlobalRdrEnv (mi_globals). - ; let final_iface = new_iface{ mi_globals = Just rdr_env } + ; let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env } ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }} where @@ -359,6 +361,17 @@ mkIface_ hsc_env maybe_old_fingerprint dflags = hsc_dflags hsc_env + -- We only fill in mi_globals if the module was compiled to byte + -- code. Otherwise, the compiler may not have retained all the + -- top-level bindings and they won't be in the TypeEnv (see + -- Desugar.addExportFlagsAndRules). The mi_globals field is used + -- by GHCi to decide whether the module has its full top-level + -- scope available. (#5534) + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv rdr_env + | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env + | otherwise = Nothing + deliberatelyOmitted :: String -> a deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) @@ -380,7 +393,7 @@ mkIface_ hsc_env maybe_old_fingerprint ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () writeIfaceFile dflags location new_iface - = do createDirectoryHierarchy (takeDirectory hi_file_path) + = do createDirectoryIfMissing True (takeDirectory hi_file_path) writeBinIface dflags hi_file_path new_iface where hi_file_path = ml_hi_file location @@ -583,7 +596,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - (some of) dflags -- it returns two hashes, one that shouldn't change -- the abi hash and one that should - flag_hash <- fingerprintDynFlags dflags putNameLiterally + flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally -- the ABI hash depends on: -- - decls @@ -1073,11 +1086,28 @@ Trac #5362 for an example. Such Names are always %* * Load the old interface file for this module (unless we have it already), and check whether it is up to date - %* * %************************************************************************ \begin{code} +data RecompileRequired + = UpToDate + -- ^ everything is up to date, recompilation is not required + | MustCompile + -- ^ The .hs file has been touched, or the .o/.hi file does not exist + | RecompBecause String + -- ^ The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + | RecompForcedByTH + -- ^ recompile is forced due to use of TH by the module + deriving Eq + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + + + -- | Top level function to check if the version of an old interface file -- is equivalent to the current source file the user asked us to compile. -- If the same, we can avoid recompilation. We return a tuple where the @@ -1097,7 +1127,7 @@ checkOldIface hsc_env mod_summary source_modified maybe_iface check_old_iface hsc_env mod_summary source_modified maybe_iface check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface - -> IfG (Bool, Maybe ModIface) + -> IfG (RecompileRequired, Maybe ModIface) check_old_iface hsc_env mod_summary src_modified maybe_iface = let dflags = hsc_dflags hsc_env getIface = @@ -1131,19 +1161,19 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface -- avoid reading an interface; just return the one we might -- have been supplied with. True | not (isObjectTarget $ hscTarget dflags) -> - return (outOfDate, maybe_iface) + return (MustCompile, maybe_iface) -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it True -> do maybe_iface' <- getIface - return (outOfDate, maybe_iface') + return (MustCompile, maybe_iface') False -> do maybe_iface' <- getIface case maybe_iface' of -- We can't retrieve the iface - Nothing -> return (outOfDate, Nothing) + Nothing -> return (MustCompile, Nothing) -- We have got the old iface; check its versions -- even in the SourceUnmodifiedAndStable case we @@ -1151,15 +1181,6 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface -- might have changed or gone away. Just iface -> checkVersions hsc_env mod_summary iface --- | @recompileRequired@ is called from the HscMain. It checks whether --- a recompilation is required. It needs access to the persistent state, --- finder, etc, because it may have to load lots of interface files to --- check their versions. -type RecompileRequired = Bool -upToDate, outOfDate :: Bool -upToDate = False -- Recompile not required -outOfDate = True -- Recompile required - -- | Check if a module is still the same 'version'. -- -- This function is called in the recompilation checker after we have @@ -1180,9 +1201,9 @@ checkVersions hsc_env mod_summary iface ppr (mi_module iface) <> colon) ; recomp <- checkFlagHash hsc_env iface - ; if recomp then return (outOfDate, Nothing) else do { + ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- checkDependencies hsc_env mod_summary iface - ; if recomp then return (outOfDate, Just iface) else do { + ; if recompileRequired recomp then return (recomp, Just iface) else do { -- Source code unchanged and no errors yet... carry on -- @@ -1211,10 +1232,13 @@ checkVersions hsc_env mod_summary iface checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do let old_hash = mi_flag_hash iface - new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) putNameLiterally + new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) + (mi_module iface) + putNameLiterally case old_hash == new_hash of True -> up_to_date (ptext $ sLit "Module flags unchanged") - False -> out_of_date_hash (ptext $ sLit " Module flags have changed") + False -> out_of_date_hash "flags changed" + (ptext $ sLit " Module flags have changed") old_hash new_hash -- If the direct imports of this module are resolved to targets that @@ -1229,18 +1253,16 @@ checkFlagHash hsc_env iface = do -- Returns True if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface - = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) where prev_dep_mods = dep_mods (mi_deps iface) prev_dep_pkgs = dep_pkgs (mi_deps iface) this_pkg = thisPackage (hsc_dflags hsc_env) - orM = foldr f (return False) - where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do find_res <- liftIO $ findImportedModule hsc_env mod pkg + let reason = moduleNameString mod ++ " changed" case find_res of Found _ mod | pkg == this_pkg @@ -1248,20 +1270,20 @@ checkDependencies hsc_env summary iface then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " not among previous dependencies" - return outOfDate + return (RecompBecause reason) else - return upToDate + return UpToDate | otherwise -> if pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> text ", which is not among previous dependencies" - return outOfDate + return (RecompBecause reason) else - return upToDate + return UpToDate where pkg = modulePackageId mod - _otherwise -> return outOfDate + _otherwise -> return (RecompBecause reason) needInterface :: Module -> (ModIface -> IfG RecompileRequired) -> IfG RecompileRequired @@ -1275,8 +1297,10 @@ needInterface mod continue -- Instead, get an Either back which we can test case mb_iface of - Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"), - ppr mod])) + Failed _ -> do + traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"), + ppr mod]) + return MustCompile -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain: it might -- just be that the current module doesn't need that @@ -1292,7 +1316,8 @@ checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } = needInterface mod $ \iface -> do - checkModuleFingerprint old_mod_hash (mi_mod_hash iface) + let reason = moduleNameString (moduleName mod) ++ " changed" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) -- We only track the ABI hash of package modules, rather than -- individual entity usages, so if the ABI hash changes we must -- recompile. This is safe but may entail more recompilation when @@ -1312,19 +1337,21 @@ checkModUsage this_pkg UsageHomeModule{ new_decl_hash = mi_hash_fn iface new_export_hash = mi_exp_hash iface + reason = moduleNameString mod_name ++ " changed" + -- CHECK MODULE - recompile <- checkModuleFingerprint old_mod_hash new_mod_hash - if not recompile then return upToDate else do - + recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) then return UpToDate else do + -- CHECK EXPORT LIST - checkMaybeHash maybe_old_export_hash new_export_hash + checkMaybeHash reason maybe_old_export_hash new_export_hash (ptext (sLit " Export list changed")) $ do -- CHECK ITEMS ONE BY ONE - recompile <- checkList [ checkEntityUsage new_decl_hash u + recompile <- checkList [ checkEntityUsage reason new_decl_hash u | u <- old_decl_hash] - if recompile - then return outOfDate -- This one failed, so just bail out now + if recompileRequired recompile + then return recompile -- This one failed, so just bail out now else up_to_date (ptext (sLit " Great! The bits I use are up to date")) @@ -1333,65 +1360,72 @@ checkModUsage _this_pkg UsageFile{ usg_file_path = file, liftIO $ handleIO handle $ do new_mtime <- getModificationUTCTime file - return $ old_mtime /= new_mtime + if (old_mtime /= new_mtime) + then return recomp + else return UpToDate where + recomp = RecompBecause (file ++ " changed") handle = #ifdef DEBUG - \e -> pprTrace "UsageFile" (text (show e)) $ return True + \e -> pprTrace "UsageFile" (text (show e)) $ return recomp #else - \_ -> return True -- if we can't find the file, just recompile, don't fail + \_ -> return recomp -- if we can't find the file, just recompile, don't fail #endif ------------------------ -checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG RecompileRequired -checkModuleFingerprint old_mod_hash new_mod_hash +checkModuleFingerprint :: String -> Fingerprint -> Fingerprint + -> IfG RecompileRequired +checkModuleFingerprint reason old_mod_hash new_mod_hash | new_mod_hash == old_mod_hash = up_to_date (ptext (sLit "Module fingerprint unchanged")) | otherwise - = out_of_date_hash (ptext (sLit " Module fingerprint has changed")) + = out_of_date_hash reason (ptext (sLit " Module fingerprint has changed")) old_mod_hash new_mod_hash ------------------------ -checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc +checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc -> IfG RecompileRequired -> IfG RecompileRequired -checkMaybeHash maybe_old_hash new_hash doc continue +checkMaybeHash reason maybe_old_hash new_hash doc continue | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash doc hash new_hash + = out_of_date_hash reason doc hash new_hash | otherwise = continue ------------------------ -checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint)) +checkEntityUsage :: String + -> (OccName -> Maybe (OccName, Fingerprint)) -> (OccName, Fingerprint) -> IfG RecompileRequired -checkEntityUsage new_hash (name,old_hash) +checkEntityUsage reason new_hash (name,old_hash) = case new_hash name of Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext (sLit "No longer exported:"), ppr name]) + out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name]) Just (_, new_hash) -- It's there, but is it up to date? | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) - return upToDate - | otherwise -> out_of_date_hash (ptext (sLit " Out of date:") <+> ppr name) + return UpToDate + | otherwise -> out_of_date_hash reason (ptext (sLit " Out of date:") <+> ppr name) old_hash new_hash -up_to_date, out_of_date :: SDoc -> IfG RecompileRequired -up_to_date msg = traceHiDiffs msg >> return upToDate -out_of_date msg = traceHiDiffs msg >> return outOfDate +up_to_date :: SDoc -> IfG RecompileRequired +up_to_date msg = traceHiDiffs msg >> return UpToDate + +out_of_date :: String -> SDoc -> IfG RecompileRequired +out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) -out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired -out_of_date_hash msg old_hash new_hash - = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash]) +out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired +out_of_date_hash reason msg old_hash new_hash + = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash]) ---------------------- checkList :: [IfG RecompileRequired] -> IfG RecompileRequired -- This helper is used in two places -checkList [] = return upToDate +checkList [] = return UpToDate checkList (check:checks) = do recompile <- check - if recompile - then return outOfDate + if recompileRequired recompile + then return recompile else checkList checks \end{code} @@ -1425,6 +1459,7 @@ tyThingToIfaceDecl (ATyCon tycon) | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, + ifCType = tyConCType tycon, ifTyVars = toIfaceTvBndrs tyvars, ifCtxt = toIfaceContext (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a081fbe36e..e0b0f1d2a8 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -41,7 +41,7 @@ import TyCon import DataCon import PrelNames import TysWiredIn -import TysPrim ( tySuperKindTyCon ) +import TysPrim ( superKindTyConName ) import BasicTypes ( Arity, strongLoopBreaker ) import Literal import qualified Var @@ -432,6 +432,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ; return (AnId (mkGlobalId details name ty info)) } tc_iface_decl parent _ (IfaceData {ifName = occ_name, + ifCType = cType, ifTyVars = tv_bndrs, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, @@ -443,7 +444,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tyvars mb_axiom_name ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; return (buildAlgTyCon tc_name tyvars stupid_theta + ; return (buildAlgTyCon tc_name tyvars cType stupid_theta cons is_rec gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@ -1242,6 +1243,9 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids + -- Even though we are in an interface file, we want to make + -- sure the instances and RULES of this thing (particularly TyCon) are loaded + -- Imagine: f :: Double -> Double = do { ifCheckWiredInThing thing; return thing } | otherwise = do { env <- getGblEnv @@ -1286,37 +1290,13 @@ tcIfaceGlobal name -- emasculated form (e.g. lacking data constructors). tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon -tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon -tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon -tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon -tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon -tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) -tcIfaceTyCon (IfaceIPTc n) = do { n' <- newIPName n - ; tcWiredInTyCon (ipTyCon n') } -tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name - ; return (check_tc (tyThingTyCon thing)) } - where - check_tc tc - | debugIsOn = case toIfaceTyCon tc of - IfaceTc _ -> tc - _ -> pprTrace "check_tc" (ppr tc) tc - | otherwise = tc --- we should be okay just returning Kind constructors without extra loading -tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon -tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon -tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon -tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon -tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon -tcIfaceTyCon IfaceSuperKindTc = return tySuperKindTyCon - --- Even though we are in an interface file, we want to make --- sure the instances and RULES of this tycon are loaded --- Imagine: f :: Double -> Double -tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc) - ; return tc } +tcIfaceTyCon (IfaceTc name) + = do { thing <- tcIfaceGlobal name + ; case thing of -- A "type constructor" can be a promoted data constructor + -- c.f. Trac #5881 + ATyCon tc -> return tc + ADataCon dc -> return (buildPromotedDataCon dc) + _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) } tcIfaceCoAxiom :: Name -> IfL CoAxiom tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name @@ -1388,7 +1368,7 @@ bindIfaceTyVars bndrs thing_inside (occs,kinds) = unzip bndrs isSuperIfaceKind :: IfaceKind -> Bool -isSuperIfaceKind (IfaceTyConApp IfaceSuperKindTc []) = True +isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName isSuperIfaceKind _ = False mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 059328f868..70fa51aaa2 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -172,7 +172,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier) _ _ _ +genCall env (CmmPrim MO_WriteBarrier _) _ _ _ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] = return (env, nilOL, []) | getLlvmVer env > 29 = barrier env @@ -182,7 +182,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ -- 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 -- is strict about types. -genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do +genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do let width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible @@ -202,9 +202,10 @@ genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || - op == MO_Memset || - op == MO_Memmove = do +genCall env t@(CmmPrim op _) [] args CmmMayReturn + | op == MO_Memcpy || + op == MO_Memset || + op == MO_Memmove = do let (isVolTy, isVolVal) = if getLlvmVer env >= 28 then ([i1], [mkIntLit i1 0]) else ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy @@ -222,6 +223,9 @@ genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || `appOL` trashStmts `snocOL` call return (env2, stmts, top1 ++ top2) +genCall env (CmmPrim _ (Just stmts)) _ _ _ + = stmtsToInstrs env stmts (nilOL, []) + -- Handle all other foreign calls and prim ops. genCall env target res args ret = do @@ -240,7 +244,7 @@ genCall env target res args ret = do -- extract Cmm call convention let cconv = case target of CmmCallee _ conv -> conv - CmmPrim _ -> PrimCallConv + CmmPrim _ _ -> PrimCallConv -- translate to LLVM call convention let lmconv = case cconv of @@ -337,7 +341,7 @@ getFunPtr env funTy targ = case targ of (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (env', v2, stmts `snocOL` s1, top) - CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop + CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop where litCase name = do @@ -469,17 +473,20 @@ cmmPrimOpFunctions env mop (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) - MO_WriteBarrier -> - panic $ "cmmPrimOpFunctions: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "cmmPrimOpFunctions: MO_Touch not supported here" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported where intrinTy1 = (if getLlvmVer env >= 28 then "p0i8.p0i8." else "") ++ show llvmWord intrinTy2 = (if getLlvmVer env >= 28 then "p0i8." else "") ++ show llvmWord - + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") -- | Tail function calls genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index a9ab3f66b7..88ba0b5741 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -17,7 +17,6 @@ import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import Util import OldCmm ( RawCmmGroup ) import HscTypes import DynFlags @@ -190,7 +189,7 @@ outputForeignStubs dflags mod location stubs stub_h_output_w = showSDoc stub_h_output_d -- in - createDirectoryHierarchy (takeDirectory stub_h) + createDirectoryIfMissing True (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index df6e7fd163..488df37a79 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1176,14 +1176,17 @@ runPhase As input_fn dflags = do llvmVer <- io $ figureLlvmVersion dflags return $ case llvmVer of - Just n | n >= 30 -> SysTools.runClang - _ -> SysTools.runAs + -- using cGccLinkerOpts here but not clear if + -- opt_c isn't a better choice + Just n | n >= 30 -> + (SysTools.runClang, cGccLinkerOpts) + + _ -> (SysTools.runAs, getOpts dflags opt_a) | otherwise - = return SysTools.runAs + = return (SysTools.runAs, getOpts dflags opt_a) - as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a + (as_prog, as_opts) <- whichAsProg let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub @@ -1191,7 +1194,7 @@ runPhase As input_fn dflags -- we create directories for the object file, because it -- might be a hierarchical module. - io $ createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryIfMissing True (takeDirectory output_fn) io $ as_prog dflags (map SysTools.Option as_opts @@ -1230,7 +1233,7 @@ runPhase SplitAs _input_fn dflags osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - io $ createDirectoryHierarchy split_odir + io $ createDirectoryIfMissing True split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. @@ -1453,9 +1456,9 @@ runPhase_MoveBinary dflags input_fn return True | otherwise = return True -mkExtraCObj :: DynFlags -> String -> IO FilePath -mkExtraCObj dflags xs - = do cFile <- newTempName dflags "c" +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId @@ -1474,10 +1477,8 @@ mkExtraCObj dflags xs -- so now we generate and compile a main() stub as part of every -- binary and pass the -rtsopts setting directly to the RTS (#5373) -- -mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath -mkExtraObjToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do let have_rts_opts_flags = isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of RtsOptsSafeOnly -> False @@ -1487,10 +1488,7 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do hPutStrLn stderr $ "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main.\n" ++ " Call hs_init_ghc() from your main() function to set these options." - mkExtraCObj dflags (showSDoc (vcat [main, - link_opts link_info] - <> char '\n')) -- final newline, to - -- keep gcc happy + mkExtraObj dflags "c" (showSDoc main) where main @@ -1508,23 +1506,32 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do Just opts -> ptext (sLit " __conf.rts_opts= ") <> text (show opts) <> semi, ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"), - char '}' + char '}', + char '\n' -- final newline, to keep gcc happy ] - link_opts info - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - = empty - | otherwise = hcat [ - text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, - text ",\\\"\\\",", - text elfSectionNote, - text "\\n", +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc (link_opts link_info)) + else return [] + + where + link_opts info = hcat [ + text "\t.section ", text ghcLinkInfoSectionName, + text ",\"\",", + text elfSectionNote, + text "\n", - text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + text "\t.ascii \"", info', text "\"\n" ] where - -- we need to escape twice: once because we're inside a C string, - -- and again because we're inside an asm string. - info' = text $ (escape.escape) info + info' = text $ escape info escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) @@ -1661,7 +1668,8 @@ linkBinary dflags o_files dep_packages = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1778,7 +1786,7 @@ linkBinary dflags o_files dep_packages = do ++ framework_path_opts ++ framework_opts ++ pkg_lib_path_opts - ++ [extraLinkObj] + ++ extraLinkObj:noteLinkObjs ++ pkg_link_opts ++ pkg_framework_path_opts ++ pkg_framework_opts @@ -2132,6 +2140,6 @@ hscPostBackendPhase dflags _ hsc_lang = touchObjectFile :: DynFlags -> FilePath -> IO () touchObjectFile dflags path = do - createDirectoryHierarchy $ takeDirectory path + createDirectoryIfMissing True $ takeDirectory path SysTools.touch dflags "Touching object file" path diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 747b0b8f71..eeb1dfc280 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -16,7 +16,8 @@ module DynFlags ( DynFlag(..), WarningFlag(..), ExtensionFlag(..), - LogAction, + Language(..), + LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, dopt, @@ -28,10 +29,12 @@ module DynFlags ( xopt, xopt_set, xopt_unset, + lang_set, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), @@ -61,6 +64,8 @@ module DynFlags ( defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags defaultLogAction, + defaultFlushOut, + defaultFlushErr, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -128,7 +133,7 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath -import System.IO ( stderr, hPutChar ) +import System.IO import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -585,6 +590,8 @@ data DynFlags = DynFlags { -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, + flushOut :: FlushOut, + flushErr :: FlushErr, haddockOptions :: Maybe String, @@ -728,7 +735,7 @@ wayNames = map wayName . ways -- from an imported module. This will fail if no code has been generated -- for this module. You can use 'GHC.needsTemplateHaskell' to detect -- whether this might be the case and choose to either switch to a --- different target or avoid typechecking such modules. (The latter may +-- different target or avoid typechecking such modules. (The latter may be -- preferable for security reasons.) -- data HscTarget @@ -753,6 +760,17 @@ isObjectTarget HscAsm = True isObjectTarget HscLlvm = True isObjectTarget _ = False +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to @@ -930,6 +948,8 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction, + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, profAuto = NoProfAuto, llvmVersion = panic "defaultDynFlags: No llvmVersion" } @@ -948,6 +968,16 @@ defaultLogAction severity srcSpan style msg -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -1050,15 +1080,16 @@ xopt_unset dfs f in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () -setLanguage l = upd f - where f dfs = let mLang = Just l - oneoffs = extensions dfs - in dfs { - language = mLang, - extensionFlags = flattenExtensionFlags mLang oneoffs - } +setLanguage l = upd (`lang_set` Just l) -- | Some modules have dependencies on others through the DynFlags rather than textual imports dynFlagDependencies :: DynFlags -> [ModuleName] diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 6ba9df436c..be7f2544e6 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprLocErrMsg, makeIntoWarning, errorsFound, emptyMessages, @@ -41,6 +41,7 @@ import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) +import System.Directory import System.Exit ( ExitCode(..), exitWith ) import System.FilePath import Data.List @@ -95,9 +96,6 @@ mkLocMessage severity locn msg -- For warnings, print Foo.hs:34: Warning: -- <the warning message> -printError :: SrcSpan -> MsgDoc -> IO () -printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle - makeIntoWarning :: ErrMsg -> ErrMsg makeIntoWarning err = err { errMsgSeverity = SevWarning } @@ -239,7 +237,7 @@ dumpSDoc dflags dflag hdr doc mode = if append then AppendMode else WriteMode when (not append) $ writeIORef gdref (Set.insert fileName gd) - createDirectoryHierarchy (takeDirectory fileName) + createDirectoryIfMissing True (takeDirectory fileName) handle <- openFile fileName mode hPrintDump handle doc hClose handle diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d3a8bb11de..9e33aae2bb 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -24,8 +24,9 @@ module GHC ( DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, GhcMode(..), GhcLink(..), defaultObjectTarget, parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, + getSessionDynFlags, setSessionDynFlags, + getProgramDynFlags, setProgramDynFlags, + getInteractiveDynFlags, setInteractiveDynFlags, parseStaticFlags, -- * Targets @@ -323,11 +324,12 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a -defaultErrorHandler la inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) + => LogAction -> FlushOut -> m a -> m a +defaultErrorHandler la (FlushOut flushOut) inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do - hFlush stdout + flushOut case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> @@ -347,7 +349,7 @@ defaultErrorHandler la inner = -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do - hFlush stdout + flushOut case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) @@ -448,11 +450,33 @@ initGhcMonad mb_top_dir = do -- %* * -- %************************************************************************ --- | Updates the DynFlags in a Session. This also reads --- the package database (unless it has already been read), --- and prepares the compilers knowledge about packages. It --- can be called again to load new packages: just add new --- package flags to (packageFlags dflags). +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + + +-- | Updates both the interactive and program DynFlags in a Session. +-- This also reads the package database (unless it has already been +-- read), and prepares the compilers knowledge about packages. It can +-- be called again to load new packages: just add new package flags to +-- (packageFlags dflags). -- -- Returns a list of new packages that may need to be linked in using -- the dynamic linker (see 'linkPackages') as a result of new package @@ -462,9 +486,33 @@ initGhcMonad mb_top_dir = do setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] setSessionDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags - modifySession (\h -> h{ hsc_dflags = dflags' }) + modifySession $ \h -> h{ hsc_dflags = dflags' + , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } } + return preload + +-- | Sets the program 'DynFlags'. +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setProgramDynFlags dflags = do + (dflags', preload) <- liftIO $ initPackages dflags + modifySession $ \h -> h{ hsc_dflags = dflags' } return preload +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'pkgState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }} + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + parseDynamicFlags :: Monad m => DynFlags -> [Located String] diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index a2fb9edf16..545993d62d 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -198,8 +198,7 @@ load2 how_much mod_graph = do -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } + modifySession $ \_ -> discardIC $ hsc_env { hsc_HPT = pruned_hpt } liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) @@ -362,16 +361,20 @@ loadFinish _all_ok Failed -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. loadFinish all_ok Succeeded - = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + = do modifySession discardIC return all_ok -- Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- discard the contents of the InteractiveContext, but keep the DynFlags +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) } intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () intermediateCleanTempFiles dflags summaries hsc_env diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 1fe9077046..efad3b7d3c 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -175,7 +175,7 @@ newHscEnv dflags = do return HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, + hsc_IC = emptyInteractiveContext dflags, hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var, @@ -217,6 +217,13 @@ runHsc hsc_env (Hsc hsc) = do printOrThrowWarnings (hsc_dflags hsc_env) w return a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +-- +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +runInteractiveHsc hsc_env = + runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) }) + getWarnings :: Hsc WarningMessages getWarnings = Hsc $ \_ w -> return (w, w) @@ -287,31 +294,36 @@ ioMsgMaybe' ioA = do #ifdef GHCI hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name] -hscTcRnLookupRdrName hsc_env rdr_name = - runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name +hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name #endif hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name -- ignore errors: the only error we're likely to get is -- "name not found", and the Maybe in the return type -- is used to indicate that. hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst])) -hscTcRnGetInfo hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name +hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI hscGetModuleInterface :: HscEnv -> Module -> IO ModIface -hscGetModuleInterface hsc_env mod = - runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env import_decls = - runHsc hsc_env $ ioMsgMaybe $ tcRnImportDecls hsc_env import_decls +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls #endif -- ----------------------------------------------------------------------------- @@ -538,7 +550,7 @@ data HsCompiler a = HsCompiler { } genericHscCompile :: HsCompiler a - -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()) + -> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ()) -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> Maybe (Int, Int) -> IO a @@ -556,7 +568,7 @@ genericHscCompile compiler hscMessage hsc_env let mb_old_hash = fmap mi_iface_hash mb_checked_iface let skip iface = do - hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary + hscMessage hsc_env mb_mod_index UpToDate mod_summary runHsc hsc_env $ hscNoRecomp compiler iface compile reason = do @@ -579,12 +591,12 @@ genericHscCompile compiler hscMessage hsc_env -- doing for us in one-shot mode. case mb_checked_iface of - Just iface | not recomp_reqd -> + Just iface | not (recompileRequired recomp_reqd) -> if mi_used_th iface && not stable then compile RecompForcedByTH else skip iface _otherwise -> - compile RecompRequired + compile recomp_reqd hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a hscCheckRecompBackend compiler tc_result hsc_env mod_summary @@ -597,7 +609,7 @@ hscCheckRecompBackend compiler tc_result hsc_env mod_summary let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of - Just iface | not recomp_reqd + Just iface | not (recompileRequired recomp_reqd) -> runHsc hsc_env $ hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) } @@ -788,32 +800,33 @@ genModDetails old_iface -- Progress displayers. -------------------------------------------------------------- -data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH - deriving Eq - -oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary + -> IO () oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = case recomp of - RecompNotRequired -> + UpToDate -> compilationProgressMsg (hsc_dflags hsc_env) $ "compilation IS NOT required" _other -> return () -batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary + -> IO () batchMsg hsc_env mb_mod_index recomp mod_summary = case recomp of - RecompRequired -> showMsg "Compiling " - RecompNotRequired - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" | otherwise -> return () - RecompForcedByTH -> showMsg "Compiling [TH] " + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + RecompForcedByTH -> showMsg "Compiling " " [TH]" where - showMsg msg = + showMsg msg reason = compilationProgressMsg (hsc_dflags hsc_env) $ (showModuleIndex mb_mod_index ++ msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) - (recomp == RecompRequired) mod_summary) + (recompileRequired recomp) mod_summary) + ++ reason -------------------------------------------------------------- -- FrontEnds @@ -1378,7 +1391,9 @@ hscStmtWithLocation :: HscEnv -> String -- ^ The source -> Int -- ^ Starting line -> IO (Maybe ([Id], IO [HValue])) -hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing @@ -1418,7 +1433,9 @@ hscDeclsWithLocation :: HscEnv -> String -- ^ The source -> Int -- ^ Starting line -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do +hscDeclsWithLocation hsc_env0 str source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv L _ (HsModule{ hsmodDecls = decls }) <- hscParseThingWithLocation source linenumber parseModule str @@ -1489,7 +1506,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do return (tythings, ictxt) hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) -hscImport hsc_env str = runHsc hsc_env $ do +hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule str case is of @@ -1502,7 +1519,8 @@ hscImport hsc_env str = runHsc hsc_env $ do hscTcExpr :: HscEnv -> String -- ^ The expression -> IO Type -hscTcExpr hsc_env expr = runHsc hsc_env $ do +hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (ExprStmt expr _ _ _)) -> @@ -1517,7 +1535,8 @@ hscKcType -> Bool -- ^ Normalise the type -> String -- ^ The type as a string -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env normalise str = runHsc hsc_env $ do +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty @@ -1535,7 +1554,7 @@ hscParseType = hscParseThing parseType hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = - runHsc hsc_env $ hscParseThing parseIdentifier str + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing hscParseThing = hscParseThingWithLocation "<interactive>" 1 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9840b407ce..adc98765cf 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -917,6 +917,10 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) -- context in which statements are executed in a GHC session. data InteractiveContext = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interative expressions + -- and statements. + ic_imports :: [InteractiveImport], -- ^ The GHCi context is extended with these imports -- @@ -977,9 +981,10 @@ hscDeclsWithLocation) and save them in ic_sys_vars. -} -- | Constructs an empty InteractiveContext. -emptyInteractiveContext :: InteractiveContext -emptyInteractiveContext - = InteractiveContext { ic_imports = [], +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { ic_dflags = dflags, + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tythings = [], ic_sys_vars = [], @@ -1041,7 +1046,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule Module + | IIModule ModuleName -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index cdc2ca501a..8cc94a3ce8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -195,8 +195,9 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } } -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber @@ -208,8 +209,8 @@ runStmtWithLocation source linenumber expr step = Just (tyThings, hval) -> do status <- withVirtualCWD $ - withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - liftIO $ sandboxIO dflags' statusMVar hval + withBreakAction (isStep step) idflags' breakMVar statusMVar $ do + liftIO $ sandboxIO idflags' statusMVar hval let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -229,13 +230,7 @@ runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] runDeclsWithLocation source linenumber expr = do hsc_env <- getSession - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber + (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession @@ -822,7 +817,7 @@ findGlobalRdrEnv hsc_env imports idecls :: [LImportDecl RdrName] idecls = [noLoc d | IIDecl d <- imports] - imods :: [Module] + imods :: [ModuleName] imods = [m | IIModule m <- imports] availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv @@ -836,9 +831,9 @@ availsToGlobalRdrEnv mod_name avails is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } -mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv +mkTopLevEnv :: HomePackageTable -> ModuleName -> IO GlobalRdrEnv mkTopLevEnv hpt modl - = case lookupUFM hpt (moduleName modl) of + = case lookupUFM hpt modl of Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ showSDoc (ppr modl))) Just details -> diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index b46ca17f49..5d643f1319 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -922,7 +922,8 @@ traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags ; showPass dflags phase_name ; debugTraceMsg dflags 3 (text cmd_line) - ; hFlush stderr + ; case flushErr dflags of + FlushErr io -> io -- And run it! ; action `catchIO` handle_exn verb diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 34afd5ca0e..01de9af4ee 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -309,6 +309,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; omit_prags = dopt Opt_OmitInterfacePragmas dflags ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = xopt Opt_TemplateHaskell dflags + ; data_kinds = xopt Opt_DataKinds dflags + ; no_trim_types = th || data_kinds + -- See Note [When we can't trim types] } ; showPass dflags CoreTidy @@ -334,7 +337,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] - ; tidy_type_env = tidyTypeEnv omit_prags th export_set + ; tidy_type_env = tidyTypeEnv omit_prags no_trim_types export_set (extendTypeEnvWithIds type_env final_ids) ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts @@ -410,7 +413,7 @@ lookup_dfun type_env dfun_id -------------------------- tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> Bool -- Template Haskell is on + -> Bool -- Type-trimming flag -> NameSet -> TypeEnv -> TypeEnv -- The competed type environment is gotten from @@ -423,11 +426,11 @@ tidyTypeEnv :: Bool -- Compiling without -O, so omit prags -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags th exports type_env +tidyTypeEnv omit_prags no_trim_types exports type_env = let type_env1 = filterNameEnv (not . isWiredInName . getName) type_env -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1 + type_env2 | omit_prags = mapNameEnv (trimThing no_trim_types exports) type_env1 | otherwise = type_env1 -- (2) trimmed if necessary in @@ -436,9 +439,9 @@ tidyTypeEnv omit_prags th exports type_env -------------------------- trimThing :: Bool -> NameSet -> TyThing -> TyThing -- Trim off inessentials, for boot files and no -O -trimThing th exports (ATyCon tc) - | not th && not (mustExposeTyCon exports tc) - = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell] +trimThing no_trim_types exports (ATyCon tc) + | not (mustExposeTyCon no_trim_types exports tc) + = ATyCon (makeTyConAbstract tc) -- Note [When we can't trim types] trimThing _th _exports (AnId id) | not (isImplicitId id) @@ -448,30 +451,61 @@ trimThing _th _exports other_thing = other_thing -{- Note [Trimming and Template Haskell] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #2386) this +{- Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (Trac #2386) this module M(T, makeOne) where data T = Yay String makeOne = [| Yay "Yep" |] Notice that T is exported abstractly, but makeOne effectively exports it too! A module that splices in $(makeOne) will then look for a declartion of Yay, so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. -} - - -mustExposeTyCon :: NameSet -- Exports +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (Trac #5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + -} + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports -> TyCon -- The tycon -> Bool -- Can its rep be hidden? -- We are compiling without -O, and thus trying to write as little as -- possible into the interface file. But we must expose the details of -- any data types whose constructors or fields are exported -mustExposeTyCon exports tc - | not (isAlgTyCon tc) -- Synonyms +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) = True + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors = True -- won't lead to the need for further exposure -- (This includes data types with no constructors.) + | isFamilyTyCon tc -- Open type family = True diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 02878bfff5..1ad1242b31 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -1,19 +1,12 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1993-2004 --- +-- -- This is the top-level module in the native code generator. -- -- ----------------------------------------------------------------------------- \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 AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" @@ -40,12 +33,12 @@ import qualified PPC.Instr import qualified PPC.Ppr import RegAlloc.Liveness -import qualified RegAlloc.Linear.Main as Linear +import qualified RegAlloc.Linear.Main as Linear -import qualified GraphColor as Color -import qualified RegAlloc.Graph.Main as Color -import qualified RegAlloc.Graph.Stats as Color -import qualified RegAlloc.Graph.TrivColorable as Color +import qualified GraphColor as Color +import qualified RegAlloc.Graph.Main as Color +import qualified RegAlloc.Graph.Stats as Color +import qualified RegAlloc.Graph.TrivColorable as Color import TargetReg import Platform @@ -56,14 +49,14 @@ import Reg import NCGMonad import BlockId -import CgUtils ( fixStgRegisters ) +import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) import OldPprCmm import CLabel import UniqFM -import Unique ( Unique, getUnique ) +import Unique ( Unique, getUnique ) import UniqSupply import DynFlags import StaticFlags @@ -220,63 +213,63 @@ nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruc -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do - let platform = targetPlatform dflags - split_cmms = concat $ map add_split cmms + let platform = targetPlatform dflags + split_cmms = concat $ map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h - (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0 + (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0 bFlush bufh - let (native, colorStats, linearStats) - = unzip3 prof - - -- dump native code - dumpIfSet_dyn dflags - Opt_D_dump_asm "Asm code" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native) - - -- dump global NCG stats for graph coloring allocator - (case concat $ catMaybes colorStats of - [] -> return () - stats -> do - -- build the global register conflict graph - let graphGlobal - = foldl Color.union Color.initGraph - $ [ Color.raGraph stat - | stat@Color.RegAllocStatsStart{} <- stats] - - dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Color.pprStats stats graphGlobal - - dumpIfSet_dyn dflags - Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph - (targetRegDotColor platform) - (Color.trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) - $ graphGlobal) - - - -- dump global NCG stats for linear allocator - (case concat $ catMaybes linearStats of - [] -> return () - stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" - $ Linear.pprStats (concat native) stats) - - -- write out the imports - Pretty.printDoc Pretty.LeftMode h - $ makeImportsDoc dflags (concat imports) - - return () + let (native, colorStats, linearStats) + = unzip3 prof + + -- dump native code + dumpIfSet_dyn dflags + Opt_D_dump_asm "Asm code" + (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) $ concat native) + + -- dump global NCG stats for graph coloring allocator + (case concat $ catMaybes colorStats of + [] -> return () + stats -> do + -- build the global register conflict graph + let graphGlobal + = foldl Color.union Color.initGraph + $ [ Color.raGraph stat + | stat@Color.RegAllocStatsStart{} <- stats] + + dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" + $ Color.pprStats stats graphGlobal + + dumpIfSet_dyn dflags + Opt_D_dump_asm_conflicts "Register conflict graph" + $ Color.dotGraph + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) + $ graphGlobal) + + + -- dump global NCG stats for linear allocator + (case concat $ catMaybes linearStats of + [] -> return () + stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" + $ Linear.pprStats (concat native) stats) + + -- write out the imports + Pretty.printDoc Pretty.LeftMode h + $ makeImportsDoc dflags (concat imports) + + return () where add_split tops - | dopt Opt_SplitObjs dflags = split_marker : tops - | otherwise = tops + | dopt Opt_SplitObjs dflags = split_marker : tops + | otherwise = tops - split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. @@ -298,13 +291,13 @@ cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruct Maybe [Linear.RegAllocStats])] ) cmmNativeGens _ _ _ _ [] impAcc profAcc _ - = return (reverse impAcc, reverse profAcc) + = return (reverse impAcc, reverse profAcc) cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count = do let platform = targetPlatform dflags - (us', native, imports, colorStats, linearStats) + (us', native, imports, colorStats, linearStats) <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h @@ -313,149 +306,149 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let -- apparently gets inlined first. - lsPprNative <- return $! - if dopt Opt_D_dump_asm dflags - || dopt Opt_D_dump_asm_stats dflags - then native - else [] + lsPprNative <- return $! + if dopt Opt_D_dump_asm dflags + || dopt Opt_D_dump_asm_stats dflags + then native + else [] - count' <- return $! count + 1; + count' <- return $! count + 1; - -- force evaulation all this stuff to avoid space leaks + -- force evaulation all this stuff to avoid space leaks {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return () - cmmNativeGens dflags ncgImpl + cmmNativeGens dflags ncgImpl h us' cmms - (imports : impAcc) - ((lsPprNative, colorStats, linearStats) : profAcc) - count' + (imports : impAcc) + ((lsPprNative, colorStats, linearStats) : profAcc) + count' - where seqString [] = () - seqString (x:xs) = x `seq` seqString xs `seq` () + where seqString [] = () + seqString (x:xs) = x `seq` seqString xs `seq` () -- | Complete native code generation phase for a single top-level chunk of Cmm. --- Dumping the output of each stage along the way. --- Global conflict graph and NGC stats +-- Dumping the output of each stage along the way. +-- Global conflict graph and NGC stats cmmNativeGen - :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) + :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> NcgImpl statics instr jumpDest - -> UniqSupply - -> RawCmmDecl -- ^ the cmm to generate code for - -> Int -- ^ sequence number of this top thing - -> IO ( UniqSupply - , [NatCmmDecl statics instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + -> UniqSupply + -> RawCmmDecl -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing + -> IO ( UniqSupply + , [NatCmmDecl statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do let platform = targetPlatform dflags - -- rewrite assignments to global regs - let fixed_cmm = - {-# SCC "fixStgRegisters" #-} - fixStgRegisters cmm + -- rewrite assignments to global regs + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters cmm - -- cmm to cmm optimisations - let (opt_cmm, imports) = - {-# SCC "cmmToCmm" #-} - cmmToCmm dflags fixed_cmm + -- cmm to cmm optimisations + let (opt_cmm, imports) = + {-# SCC "cmmToCmm" #-} + cmmToCmm dflags fixed_cmm - dumpIfSet_dyn dflags - Opt_D_dump_opt_cmm "Optimised Cmm" + dumpIfSet_dyn dflags + Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup platform [opt_cmm]) - -- generate native code from cmm - let ((native, lastMinuteImports), usGen) = - {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm - - dumpIfSet_dyn dflags - Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native) - - -- tag instructions with register liveness information - let (withLiveness, usLive) = - {-# SCC "regLiveness" #-} - initUs usGen - $ mapUs (regLiveness platform) - $ map natCmmTopToLive native - - dumpIfSet_dyn dflags - Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map (pprPlatform platform) withLiveness) - - -- allocate registers - (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- - if ( dopt Opt_RegsGraph dflags - || dopt Opt_RegsIterative dflags) - then do - -- the regs usable for allocation - let (alloc_regs :: UniqFM (UniqSet RealReg)) - = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) - emptyUFM - $ allocatableRegs ncgImpl - - -- do the graph coloring register allocation - let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc" #-} - initUs usLive - $ Color.regAlloc - dflags - alloc_regs - (mkUniqSet [0 .. maxSpillSlots ncgImpl]) - withLiveness - - -- dump out what happened during register allocation - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced) - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc_stages "Build/spill stages" - (vcat $ map (\(stage, stats) - -> text "# --------------------------" - $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ pprPlatform platform stats) - $ zip [0..] regAllocStats) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just regAllocStats else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , mPprStats - , Nothing) - - else do - -- do linear register allocation - let ((alloced, regAllocStats), usAlloc) - = {-# SCC "RegAlloc" #-} - initUs usLive - $ liftM unzip - $ mapUs (Linear.regAlloc dflags) withLiveness - - dumpIfSet_dyn dflags - Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced) - - let mPprStats = - if dopt Opt_D_dump_asm_stats dflags - then Just (catMaybes regAllocStats) else Nothing - - -- force evaluation of the Maybe to avoid space leak - mPprStats `seq` return () - - return ( alloced, usAlloc - , Nothing - , mPprStats) + -- generate native code from cmm + let ((native, lastMinuteImports), usGen) = + {-# SCC "genMachCode" #-} + initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_asm_native "Native code" + (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native) + + -- tag instructions with register liveness information + let (withLiveness, usLive) = + {-# SCC "regLiveness" #-} + initUs usGen + $ mapUs (regLiveness platform) + $ map natCmmTopToLive native + + dumpIfSet_dyn dflags + Opt_D_dump_asm_liveness "Liveness annotations added" + (vcat $ map (pprPlatform platform) withLiveness) + + -- allocate registers + (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- + if ( dopt Opt_RegsGraph dflags + || dopt Opt_RegsIterative dflags) + then do + -- the regs usable for allocation + let (alloc_regs :: UniqFM (UniqSet RealReg)) + = foldr (\r -> plusUFM_C unionUniqSets + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) + emptyUFM + $ allocatableRegs ncgImpl + + -- do the graph coloring register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ Color.regAlloc + dflags + alloc_regs + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) + withLiveness + + -- dump out what happened during register allocation + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc_stages "Build/spill stages" + (vcat $ map (\(stage, stats) + -> text "# --------------------------" + $$ text "# cmm " <> int count <> text " Stage " <> int stage + $$ pprPlatform platform stats) + $ zip [0..] regAllocStats) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just regAllocStats else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , mPprStats + , Nothing) + + else do + -- do linear register allocation + let ((alloced, regAllocStats), usAlloc) + = {-# SCC "RegAlloc" #-} + initUs usLive + $ liftM unzip + $ mapUs (Linear.regAlloc dflags) withLiveness + + dumpIfSet_dyn dflags + Opt_D_dump_asm_regalloc "Registers allocated" + (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) alloced) + + let mPprStats = + if dopt Opt_D_dump_asm_stats dflags + then Just (catMaybes regAllocStats) else Nothing + + -- force evaluation of the Maybe to avoid space leak + mPprStats `seq` return () + + return ( alloced, usAlloc + , Nothing + , mPprStats) ---- x86fp_kludge. This pass inserts ffree instructions to clear ---- the FPU stack on x86. The x86 ABI requires that the FPU stack @@ -467,40 +460,40 @@ cmmNativeGen dflags ncgImpl us cmm count let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced ---- generate jump tables - let tabled = - {-# SCC "generateJumpTables" #-} + let tabled = + {-# SCC "generateJumpTables" #-} generateJumpTables ncgImpl kludged - ---- shortcut branches - let shorted = - {-# SCC "shortcutBranches" #-} - shortcutBranches dflags ncgImpl tabled + ---- shortcut branches + let shorted = + {-# SCC "shortcutBranches" #-} + shortcutBranches dflags ncgImpl tabled - ---- sequence blocks - let sequenced = - {-# SCC "sequenceBlocks" #-} - map (sequenceTop ncgImpl) shorted + ---- sequence blocks + let sequenced = + {-# SCC "sequenceBlocks" #-} + map (sequenceTop ncgImpl) shorted ---- expansion of SPARC synthetic instrs - let expanded = - {-# SCC "sparc_expand" #-} + let expanded = + {-# SCC "sparc_expand" #-} ncgExpandTop ncgImpl sequenced - dumpIfSet_dyn dflags - Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded) + dumpIfSet_dyn dflags + Opt_D_dump_asm_expanded "Synthetic instructions expanded" + (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded) - return ( usAlloc - , expanded - , lastMinuteImports ++ imports - , ppr_raStatsColor - , ppr_raStatsLinear) + return ( usAlloc + , expanded + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear) x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl (ListGraph code)) = - CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) -- | Build a doc for all the imports. @@ -515,7 +508,7 @@ makeImportsDoc dflags imports (if platformHasSubsectionsViaSymbols (targetPlatform dflags) then Pretty.text ".subsections_via_symbols" else Pretty.empty) - Pretty.$$ + Pretty.$$ -- On recent GNU ELF systems one can mark an object file -- as not requiring an executable stack. If all objects -- linked into a program have this note then the program @@ -530,38 +523,38 @@ makeImportsDoc dflags imports -- an identifier directive: .ident "GHC x.y.z" (if platformHasIdentDirective (targetPlatform dflags) then let compilerIdent = Pretty.text "GHC" Pretty.<+> - Pretty.text cProjectVersion + Pretty.text cProjectVersion in Pretty.text ".ident" Pretty.<+> Pretty.doubleQuotes compilerIdent else Pretty.empty) where - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. - dyld_stubs :: [CLabel] -> Pretty.Doc + -- Generate "symbol stubs" for all external symbols that might + -- come from a dynamic library. + dyld_stubs :: [CLabel] -> Pretty.Doc {- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ - map head $ group $ sort imps-} - - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - -- (Hack) sometimes two Labels pretty-print the same, but have - -- different uniques; so we compare their text versions... - dyld_stubs imps - | needImportedSymbols arch os - = Pretty.vcat $ - (pprGotDeclaration arch os :) $ - map ( pprImportedSymbol platform . fst . head) $ - groupBy (\(_,a) (_,b) -> a == b) $ - sortBy (\(_,a) (_,b) -> compare a b) $ - map doPpr $ - imps - | otherwise - = Pretty.empty - - doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle) - astyle = mkCodeStyle AsmStyle + map head $ group $ sort imps-} + + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + -- (Hack) sometimes two Labels pretty-print the same, but have + -- different uniques; so we compare their text versions... + dyld_stubs imps + | needImportedSymbols arch os + = Pretty.vcat $ + (pprGotDeclaration arch os :) $ + map ( pprImportedSymbol platform . fst . head) $ + groupBy (\(_,a) (_,b) -> a == b) $ + sortBy (\(_,a) (_,b) -> compare a b) $ + map doPpr $ + imps + | otherwise + = Pretty.empty + + doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle) + astyle = mkCodeStyle AsmStyle -- ----------------------------------------------------------------------------- @@ -573,12 +566,12 @@ makeImportsDoc dflags imports -- such that as many of the local jumps as possible turn into -- fallthroughs. -sequenceTop - :: Instruction instr +sequenceTop + :: Instruction instr => NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr sequenceTop _ top@(CmmData _ _) = top -sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = +sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks) -- The algorithm is very simple (and stupid): we make a graph out of @@ -591,36 +584,36 @@ sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = -- FYI, the classic layout for basic blocks uses postorder DFS; this -- algorithm is implemented in Hoopl. -sequenceBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [NatBasicBlock instr] +sequenceBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [NatBasicBlock instr] sequenceBlocks [] = [] -sequenceBlocks (entry:blocks) = +sequenceBlocks (entry:blocks) = seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) -- the first block is the entry point ==> it must remain at the start. -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC ( NatBasicBlock instr - , Unique - , [Unique])] +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC ( NatBasicBlock instr + , Unique + , [Unique])] sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) -- we're only interested in the last instruction of -- the block, and only if it has a single destination. -getOutEdges - :: Instruction instr - => [instr] -> [Unique] +getOutEdges + :: Instruction instr + => [instr] -> [Unique] -getOutEdges instrs - = case jumpDestsOfInstr (last instrs) of - [one] -> [getUnique one] - _many -> [] +getOutEdges instrs + = case jumpDestsOfInstr (last instrs) of + [one] -> [getUnique one] + _many -> [] mkNode :: (Instruction t) => GenBasicBlock t @@ -635,9 +628,9 @@ seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest) | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest' | otherwise = block : seqBlocks rest' where - (can_fallthrough, rest') = reorder next [] rest - -- TODO: we should do a better job for cycles; try to maximise the - -- fallthroughs within a loop. + (can_fallthrough, rest') = reorder next [] rest + -- TODO: we should do a better job for cycles; try to maximise the + -- fallthroughs within a loop. seqBlocks _ = panic "AsmCodegen:seqBlocks" reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)]) @@ -654,18 +647,18 @@ reorder id accum (b@(block,id',out) : rest) -- big, we have to work around this limitation. makeFarBranches - :: [NatBasicBlock PPC.Instr.Instr] - -> [NatBasicBlock PPC.Instr.Instr] + :: [NatBasicBlock PPC.Instr.Instr] + -> [NatBasicBlock PPC.Instr.Instr] makeFarBranches blocks | last blockAddresses < nearLimit = blocks | otherwise = zipWith handleBlock blockAddresses blocks where blockAddresses = scanl (+) 0 $ map blockLen blocks blockLen (BasicBlock _ instrs) = length instrs - + handleBlock addr (BasicBlock id instrs) = BasicBlock id (zipWith makeFar [addr..] instrs) - + makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt makeFar addr (PPC.Instr.BCC cond tgt) | abs (addr - targetAddr) >= nearLimit @@ -674,13 +667,13 @@ makeFarBranches blocks = PPC.Instr.BCC cond tgt where Just targetAddr = lookupUFM blockAddressMap tgt makeFar _ other = other - + nearLimit = 7000 -- 8192 instructions are allowed; let's keep some -- distance, as we have a few pseudo-insns that are -- pretty-printed as multiple instructions, -- and it's just not worth the effort to calculate -- things exactly - + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses -- ----------------------------------------------------------------------------- @@ -689,7 +682,7 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl statics instr jumpDest + :: NcgImpl statics instr jumpDest -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs @@ -700,10 +693,10 @@ generateJumpTables ncgImpl xs = concatMap f xs -- Shortcut branches shortcutBranches - :: DynFlags + :: DynFlags -> NcgImpl statics instr jumpDest - -> [NatCmmDecl statics instr] - -> [NatCmmDecl statics instr] + -> [NatCmmDecl statics instr] + -> [NatCmmDecl statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -741,7 +734,7 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) -- build a mapping from BlockId to JumpDest for shorting branches mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest - + apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest -> GenCmmDecl statics h (ListGraph instr) @@ -776,21 +769,21 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode - :: DynFlags +genMachCode + :: DynFlags -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) - -> RawCmmDecl - -> UniqSM - ( [NatCmmDecl statics instr] - , [CLabel]) + -> RawCmmDecl + -> UniqSM + ( [NatCmmDecl statics instr] + , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top - = do { initial_us <- getUs - ; let initial_st = mkNatM_State initial_us 0 dflags - (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) - final_delta = natm_delta final_st - final_imports = natm_imports final_st - ; if final_delta == 0 + = do { initial_us <- getUs + ; let initial_st = mkNatM_State initial_us 0 dflags + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) + final_delta = natm_delta final_st + final_imports = natm_imports final_st + ; if final_delta == 0 then return (new_tops, final_imports) else pprPanic "genMachCode: nonzero final delta" (int final_delta) } @@ -870,8 +863,8 @@ cmmStmtConFold stmt CmmAssign reg src -> do src' <- cmmExprConFold DataReference src return $ case src' of - CmmReg reg' | reg == reg' -> CmmNop - new_src -> CmmAssign reg new_src + CmmReg reg' | reg == reg' -> CmmNop + new_src -> CmmAssign reg new_src CmmStore addr src -> do addr' <- cmmExprConFold DataReference addr @@ -883,11 +876,15 @@ cmmStmtConFold stmt return $ CmmJump addr' live CmmCall target regs args returns - -> do target' <- case target of - CmmCallee e conv -> do - e' <- cmmExprConFold CallReference e - return $ CmmCallee e' conv - other -> return other + -> do target' <- case target of + CmmCallee e conv -> do + e' <- cmmExprConFold CallReference e + return $ CmmCallee e' conv + op@(CmmPrim _ Nothing) -> + return op + CmmPrim op (Just stmts) -> + do stmts' <- mapM cmmStmtConFold stmts + return $ CmmPrim op (Just stmts') args' <- mapM (\(CmmHinted arg hint) -> do arg' <- cmmExprConFold DataReference arg return (CmmHinted arg' hint)) args @@ -897,17 +894,17 @@ cmmStmtConFold stmt -> do test' <- cmmExprConFold DataReference test dflags <- getDynFlags let platform = targetPlatform dflags - return $ case test' of - CmmLit (CmmInt 0 _) -> - CmmComment (mkFastString ("deleted: " ++ - showSDoc (pprStmt platform stmt))) + return $ case test' of + CmmLit (CmmInt 0 _) -> + CmmComment (mkFastString ("deleted: " ++ + showSDoc (pprStmt platform stmt))) - CmmLit (CmmInt _ _) -> CmmBranch dest - _other -> CmmCondBranch test' dest + CmmLit (CmmInt _ _) -> CmmBranch dest + _other -> CmmCondBranch test' dest - CmmSwitch expr ids - -> do expr' <- cmmExprConFold DataReference expr - return $ CmmSwitch expr' ids + CmmSwitch expr ids + -> do expr' <- cmmExprConFold DataReference expr + return $ CmmSwitch expr' ids other -> return other @@ -966,7 +963,7 @@ cmmExprNative referenceKind expr = do CmmReg (CmmGlobal GCEnter1) | arch == ArchPPC && not opt_PIC -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | arch == ArchPPC && not opt_PIC -> cmmExprNative referenceKind $ diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 7b704cbe8f..a30834daf6 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -358,7 +358,7 @@ iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do rlo iselExpr64 expr = do dflags <- getDynFlags - pprPanic "iselExpr64(powerpc)" (pprPlatform (targetPlatform dflags) expr) + pprPanic "iselExpr64(powerpc)" (pprExpr (targetPlatform dflags) expr) @@ -898,9 +898,12 @@ genCCall' -} -genCCall' _ (CmmPrim MO_WriteBarrier) _ _ +genCCall' _ (CmmPrim MO_WriteBarrier _) _ _ = return $ unitOL LWSYNC +genCCall' _ (CmmPrim _ (Just stmts)) _ _ + = stmtsToInstrs stmts + genCCall' gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen @@ -914,7 +917,7 @@ genCCall' gcp target dest_regs argsAndHints (labelOrExpr, reduceToFF32) <- case target of CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) CmmCallee expr _ -> return (Right expr, False) - CmmPrim mop -> outOfLineMachOp mop + CmmPrim mop _ -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -943,7 +946,7 @@ genCCall' gcp target dest_regs argsAndHints GCPLinux -> roundTo 16 finalStack -- need to remove alignment information - argsAndHints' | (CmmPrim mop) <- target, + argsAndHints' | CmmPrim mop _ <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) @@ -1142,10 +1145,14 @@ genCCall' gcp target dest_regs argsAndHints MO_PopCnt w -> (fsLit $ popCntLabel w, False) - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported") -- ----------------------------------------------------------------------------- -- Generating a table-branch diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 4c295f11d5..85fd901c42 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -6,18 +6,11 @@ -- ----------------------------------------------------------------------------- -{-# 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 ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) +module SPARC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) where @@ -26,18 +19,19 @@ where #include "../includes/MachDeps.h" -- NCG stuff: +import SPARC.Base import SPARC.CodeGen.Sanity import SPARC.CodeGen.Amode import SPARC.CodeGen.CondCode import SPARC.CodeGen.Gen64 import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.CCall import SPARC.CodeGen.Base -import SPARC.Ppr () +import SPARC.Ppr () import SPARC.Instr import SPARC.Imm import SPARC.AddrMode import SPARC.Regs +import SPARC.Stack import Instruction import Size import NCGMonad @@ -45,17 +39,22 @@ import NCGMonad -- Our intermediate code: import BlockId import OldCmm +import PIC +import Reg import CLabel +import CPrim -- The rest: +import BasicTypes import DynFlags -import StaticFlags ( opt_PIC ) +import FastString +import StaticFlags ( opt_PIC ) import OrdList import Outputable import Platform import Unique -import Control.Monad ( mapAndUnzipM ) +import Control.Monad ( mapAndUnzipM ) -- | Top level code generation cmmTopCodeGen :: RawCmmDecl @@ -77,10 +76,10 @@ cmmTopCodeGen (CmmData sec dat) = do -- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. +-- code generation may introduce new basic block boundaries, which +-- are indicated by the NEWBLOCK instruction. We must split up the +-- instruction stream into basic blocks again. Also, we extract +-- LDATAs here too. basicBlockCodeGen :: Platform -> CmmBasicBlock -> NatM ( [NatBasicBlock Instr] @@ -89,22 +88,22 @@ basicBlockCodeGen :: Platform basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) + (top,other_blocks,statics) + = foldrOL mkBlocks ([],[],[]) instrs - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) - -- do intra-block sanity checking - blocksChecked - = map (checkBlock platform cmm) - $ BasicBlock id top : other_blocks + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + + -- do intra-block sanity checking + blocksChecked + = map (checkBlock platform cmm) + $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -118,32 +117,32 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = case stmt of - CmmNop -> return nilOL + CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src - | isFloatType ty -> assignReg_FltCode size reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg - size = cmmTypeSize ty + | isFloatType ty -> assignReg_FltCode size reg src + | isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType reg + size = cmmTypeSize ty CmmStore addr src - | isFloatType ty -> assignMem_FltCode size addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src - size = cmmTypeSize ty + | isFloatType ty -> assignMem_FltCode size addr src + | isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType src + size = cmmTypeSize ty CmmCall target result_regs args _ -> genCCall target result_regs args - CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg - CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg _ -> genJump arg + CmmBranch id -> genBranch id + 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" @@ -198,8 +197,8 @@ assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_IntCode _ reg src = do r <- getRegister src return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst where dst = getRegisterReg reg @@ -212,23 +211,23 @@ assignMem_FltCode pk addr src = do (src__2, code2) <- getSomeReg src tmp1 <- getNewRegNat pk let - pk__2 = cmmExprType src - code__2 = code1 `appOL` code2 `appOL` - if sizeToWidth pk == typeWidth pk__2 + pk__2 = cmmExprType src + code__2 = code1 `appOL` code2 `appOL` + if sizeToWidth pk == typeWidth pk__2 then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] + else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 + , ST pk tmp1 dst__2] return code__2 -- Floating point assignment to a register/temporary assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_FltCode pk dstCmmReg srcCmmExpr = do srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg dstCmmReg + let dstReg = getRegisterReg dstCmmReg return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg + Any _ code -> code dstReg + Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg @@ -243,7 +242,7 @@ genJump (CmmLit (CmmLabel lbl)) genJump tree = do (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) -- ----------------------------------------------------------------------------- -- Unconditional branches @@ -272,7 +271,7 @@ allocator. genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -281,7 +280,7 @@ genCondJump genCondJump bid bool = do CondCode is_float cond code <- getCondCode bool return ( - code `appOL` + code `appOL` toOL ( if is_float then [NOP, BF cond False bid, NOP] @@ -296,34 +295,357 @@ genCondJump bid bool = do genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock genSwitch expr ids - | opt_PIC - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg expr - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] + | opt_PIC + = error "MachCodeGen: sparc genSwitch PIC not finished\n" + + | otherwise + = do (e_reg, e_code) <- getSomeReg expr + + base_reg <- getNewRegNat II32 + offset_reg <- getNewRegNat II32 + dst <- getNewRegNat II32 + + label <- getNewLabelNat + + return $ e_code `appOL` + toOL + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg + , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg + + -- the addrs in the table are 32 bits wide.. + , SLL e_reg (RIImm $ ImmInt 2) offset_reg + + -- load and jump to the destination + , LD II32 (AddrRegReg base_reg offset_reg) dst + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label + , NOP ] generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = - let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (Statics label jumpTable)) + let jumpTable = map jumpTableEntry ids + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +{- + Now the biggest nightmare---calls. Most of the nastiness is buried in + @get_arg@, which moves the arguments to the correct registers/stack + locations. Apart from that, the code is easy. + + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} + +genCCall + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + + + +-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream +-- are guaranteed to take place before writes afterwards (unlike on PowerPC). +-- Ref: Section 8.4 of the SPARC V9 Architecture manual. +-- +-- In the SPARC case we don't need a barrier. +-- +genCCall (CmmPrim (MO_WriteBarrier) _) _ _ + = do return nilOL + +genCCall (CmmPrim _ (Just stmts)) _ _ + = stmtsToInstrs stmts + +genCCall target dest_regs argsAndHints + = do + -- need to remove alignment information + let argsAndHints' | CmmPrim mop _ <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init argsAndHints + + | otherwise + = argsAndHints + + -- strip hints from the arg regs + let args :: [CmmExpr] + args = map hintlessCmm argsAndHints' + + + -- work out the arguments, and assign them to integer regs + argcode_and_vregs <- mapM arg_to_int_vregs args + let (argcodes, vregss) = unzip argcode_and_vregs + let vregs = concat vregss + + let n_argRegs = length allArgRegs + let n_argRegs_used = min (length vregs) n_argRegs + + + -- deal with static vs dynamic call targets + callinsns <- case target of + CmmCallee (CmmLit (CmmLabel lbl)) _ -> + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + CmmCallee expr _ + -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + CmmPrim mop _ + -> do res <- outOfLineMachOp mop + lblOrMopExpr <- case res of + Left lbl -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + Right mopExpr -> do + (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + return lblOrMopExpr + + let argcode = concatOL argcodes + + let (move_sp_down, move_sp_up) + = let diff = length vregs - n_argRegs + nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment + in if nn <= 0 + then (nilOL, nilOL) + else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) + + let transfer_code + = toOL (move_final vregs allArgRegs extraStackArgsHere) + + dflags <- getDynFlags + return + $ argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up `appOL` + assign_code (targetPlatform dflags) dest_regs + + +-- | Generate code to calculate an argument, and move it into one +-- or two integer vregs. +arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs arg + + -- If the expr produces a 64 bit int, then we can just use iselExpr64 + | isWord64 (cmmExprType arg) + = do (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo + return (code, [r_hi, r_lo]) + + | otherwise + = do (src, code) <- getSomeReg arg + let pk = cmmExprType arg + + case cmmTypeSize pk of + + -- Load a 64 bit float return value into two integer regs. + FF64 -> do + v1 <- getNewRegNat II32 + v2 <- getNewRegNat II32 + + let code2 = + code `snocOL` + FMOV FF64 src f0 `snocOL` + ST FF32 f0 (spRel 16) `snocOL` + LD II32 (spRel 16) v1 `snocOL` + ST FF32 f1 (spRel 16) `snocOL` + LD II32 (spRel 16) v2 + + return (code2, [v1,v2]) + + -- Load a 32 bit float return value into an integer reg + FF32 -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + ST FF32 src (spRel 16) `snocOL` + LD II32 (spRel 16) v1 + + return (code2, [v1]) + + -- Move an integer return value into its destination reg. + _ -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + OR False g0 (RIReg src) v1 + + return (code2, [v1]) + + +-- | Move args from the integer vregs into which they have been +-- marshalled, into %o0 .. %o5, and the rest onto the stack. +-- +move_final :: [Reg] -> [Reg] -> Int -> [Instr] + +-- all args done +move_final [] _ _ + = [] + +-- out of aregs; move to stack +move_final (v:vs) [] offset + = ST II32 v (spRel offset) + : move_final vs [] (offset+1) + +-- move into an arg (%o[0..5]) reg +move_final (v:vs) (a:az) offset + = OR False g0 (RIReg v) a + : move_final vs az offset + + +-- | Assign results returned from the call into their +-- desination regs. +-- +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr + +assign_code _ [] = nilOL + +assign_code platform [CmmHinted dest _hint] + = let rep = localRegType dest + width = typeWidth rep + r_dest = getRegisterReg (CmmLocal dest) + + result + | isFloatType rep + , W32 <- width + = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest + + | isFloatType rep + , W64 <- width + = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest + + | not $ isFloatType rep + , W32 <- width + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest + + | not $ isFloatType rep + , W64 <- width + , r_dest_hi <- getHiVRegFromLo r_dest + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] + + | otherwise + = panic "SPARC.CodeGen.GenCCall: no match" + + in result + +assign_code _ _ + = panic "SPARC.CodeGen.GenCCall: no match" + + + +-- | Generate a call to implement an out-of-line floating point operation +outOfLineMachOp + :: CallishMachOp + -> NatM (Either CLabel CmmExpr) + +outOfLineMachOp mop + = do let functionName + = outOfLineMachOp_table mop + + dflags <- getDynFlags + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference + $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction + + let mopLabelOrExpr + = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + + return mopLabelOrExpr + + +-- | Decide what C function to use to implement a CallishMachOp +-- +outOfLineMachOp_table + :: CallishMachOp + -> FastString + +outOfLineMachOp_table mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + MO_PopCnt w -> fsLit $ popCntLabel w + + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + where unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs deleted file mode 100644 index 91351a2e18..0000000000 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ /dev/null @@ -1,343 +0,0 @@ --- | Generating C calls - -module SPARC.CodeGen.CCall ( - genCCall -) - -where - -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Stack -import SPARC.Instr -import SPARC.Imm -import SPARC.Regs -import SPARC.Base -import CPrim -import NCGMonad -import PIC -import Instruction -import Size -import Reg - -import OldCmm -import CLabel -import BasicTypes - -import OrdList -import DynFlags -import FastString -import Outputable -import Platform - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (CmmPrim (MO_WriteBarrier)) _ _ - = do return nilOL - -genCCall target dest_regs argsAndHints - = do - -- need to remove alignment information - let argsAndHints' | (CmmPrim mop) <- target, - (mop == MO_Memcpy || - mop == MO_Memset || - mop == MO_Memmove) - = init argsAndHints - - | otherwise - = argsAndHints - - -- strip hints from the arg regs - let args :: [CmmExpr] - args = map hintlessCmm argsAndHints' - - - -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - CmmCallee expr _ - -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - CmmPrim mop - -> do res <- outOfLineMachOp mop - lblOrMopExpr <- case res of - Left lbl -> do - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - return lblOrMopExpr - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - dflags <- getDynFlags - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code (targetPlatform dflags) dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType arg - - case cmmTypeSize pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- desination regs. --- -assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [CmmHinted dest _hint] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_Memcpy -> fsLit "memcpy" - MO_Memset -> fsLit "memset" - MO_Memmove -> fsLit "memmove" - - MO_PopCnt w -> fsLit $ popCntLabel w - - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported here" - diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index c68519522d..f134255578 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1519,7 +1519,7 @@ genCCall -- Unroll memcpy calls if the source and destination pointers are at -- least DWORD aligned and the number of bytes to copy isn't too -- large. Otherwise, call C's memcpy. -genCCall is32Bit (CmmPrim MO_Memcpy) _ +genCCall is32Bit (CmmPrim MO_Memcpy _) _ [CmmHinted dst _, CmmHinted src _, CmmHinted (CmmLit (CmmInt n _)) _, CmmHinted (CmmLit (CmmInt align _)) _] @@ -1562,7 +1562,7 @@ genCCall is32Bit (CmmPrim MO_Memcpy) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_Memset) _ +genCCall _ (CmmPrim MO_Memset _) _ [CmmHinted dst _, CmmHinted (CmmLit (CmmInt c _)) _, CmmHinted (CmmLit (CmmInt n _)) _, @@ -1601,11 +1601,11 @@ genCCall _ (CmmPrim MO_Memset) _ dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - i)) -genCCall _ (CmmPrim MO_WriteBarrier) _ _ = return nilOL +genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall is32Bit (CmmPrim (MO_PopCnt width)) dest_regs@[CmmHinted dst _] +genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _] args@[CmmHinted src _] = do sse4_2 <- sse4_2Enabled if sse4_2 @@ -1641,10 +1641,10 @@ genCCall32 :: CmmCallTarget -- function to call genCCall32 target dest_regs args = case (target, dest_regs) of -- void return type prim op - (CmmPrim op, []) -> + (CmmPrim op _, []) -> outOfLineCmmOp op Nothing args -- we only cope with a single result for foreign calls - (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + (CmmPrim op _, [r_hinted@(CmmHinted r _)]) -> do l1 <- getNewLabelNat l2 <- getNewLabelNat sse2 <- sse2Enabled @@ -1673,9 +1673,70 @@ genCCall32 target dest_regs args = return (any (getRegisterReg False (CmmLocal r))) actuallyInlineFloatOp _ _ args - = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + = panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" - _ -> do + + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp False width dest_regs args + (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) + let size = intSize width + reg_l = getRegisterReg True (CmmLocal res_l) + reg_h = getRegisterReg True (CmmLocal res_h) + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + _ -> panic "genCCall32: Wrong number of arguments/results for add2" + (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let size = intSize width + reg_h = getRegisterReg True (CmmLocal res_h) + reg_l = getRegisterReg True (CmmLocal res_l) + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 size y_reg, + MOV size (OpReg rdx) (OpReg reg_h), + MOV size (OpReg rax) (OpReg reg_l)] + return code + _ -> panic "genCCall32: Wrong number of arguments/results for add2" + + (CmmPrim _ (Just stmts), _) -> + stmtsToInstrs stmts + + _ -> genCCall32' target dest_regs args + + where divOp signed width [CmmHinted res_q _, CmmHinted res_r _] + [CmmHinted arg_x _, CmmHinted arg_y _] + = do let size = intSize width + reg_q = getRegisterReg True (CmmLocal res_q) + reg_r = getRegisterReg True (CmmLocal res_r) + widen | signed = CLTD size + | otherwise = XOR size (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + return $ y_code `appOL` + x_code rax `appOL` + toOL [widen, + instr size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ + = panic "genCCall32: Wrong number of arguments/results for divOp" + +genCCall32' :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32' target dest_regs args = do let -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we @@ -1704,7 +1765,7 @@ genCCall32 target dest_regs args = -> do { (dyn_r, dyn_c) <- getSomeReg expr ; ASSERT( isWord32 (cmmExprType expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ + CmmPrim _ _ -> panic $ "genCCall: Can't handle CmmPrim call type here, error " ++ "probably because too many return values." @@ -1827,105 +1888,164 @@ genCCall64 :: CmmCallTarget -- function to call genCCall64 target dest_regs args = case (target, dest_regs) of - (CmmPrim op, []) -> + (CmmPrim op _, []) -> -- void return type prim op outOfLineCmmOp op Nothing args - (CmmPrim op, [res]) -> + (CmmPrim op _, [res]) -> -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args - _ -> do - -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL + (CmmPrim (MO_S_QuotRem width) _, _) -> divOp True width dest_regs args + (CmmPrim (MO_U_QuotRem width) _, _) -> divOp False width dest_regs args + (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do hCode <- getAnyReg (CmmLit (CmmInt 0 width)) + lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y]) + let size = intSize width + reg_l = getRegisterReg True (CmmLocal res_l) + reg_h = getRegisterReg True (CmmLocal res_h) + code = hCode reg_h `appOL` + lCode reg_l `snocOL` + ADC size (OpImm (ImmInteger 0)) (OpReg reg_h) + return code + _ -> panic "genCCall64: Wrong number of arguments/results for add2" + (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + let size = intSize width + reg_h = getRegisterReg True (CmmLocal res_h) + reg_l = getRegisterReg True (CmmLocal res_l) + code = y_code `appOL` + x_code rax `appOL` + toOL [MUL2 size y_reg, + MOV size (OpReg rdx) (OpReg reg_h), + MOV size (OpReg rax) (OpReg reg_l)] + return code + _ -> panic "genCCall64: Wrong number of arguments/results for add2" + + (CmmPrim _ (Just stmts), _) -> + stmtsToInstrs stmts + + _ -> genCCall64' target dest_regs args + + where divOp signed width [CmmHinted res_q _, CmmHinted res_r _] + [CmmHinted arg_x _, CmmHinted arg_y _] + = do let size = intSize width + reg_q = getRegisterReg True (CmmLocal res_q) + reg_r = getRegisterReg True (CmmLocal res_r) + widen | signed = CLTD size + | otherwise = XOR size (OpReg rdx) (OpReg rdx) + instr | signed = IDIV + | otherwise = DIV + (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + return $ y_code `appOL` + x_code rax `appOL` + toOL [widen, + instr size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + divOp _ _ _ _ + = panic "genCCall64: Wrong number of arguments/results for divOp" + +genCCall64' :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64' target dest_regs args = do + -- load up the register arguments + (stack_args, aregs, fregs, load_args_code) + <- load_args args allArgRegs allFPArgRegs nilOL - let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used - -- for annotating the call instruction with - sse_regs = length fp_regs_used - tot_arg_size = arg_size * length stack_args - - - -- Align stack to 16n for calls, assuming a starting stack - -- alignment of 16n - word_size on procedure entry. Which we - -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] - (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE) `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE) - return (tot_arg_size + wORD_SIZE, toOL [ - SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp), - DELTA (delta - wORD_SIZE) ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL - delta <- getDeltaNat + let + fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) + arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + -- for annotating the call instruction with + sse_regs = length fp_regs_used + tot_arg_size = arg_size * length stack_args + + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] + (real_size, adjust_rsp) <- + if (tot_arg_size + wORD_SIZE) `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... + delta <- getDeltaNat + setDeltaNat (delta - wORD_SIZE) + return (tot_arg_size + wORD_SIZE, toOL [ + SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp), + DELTA (delta - wORD_SIZE) ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,_cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." - -- deal with static vs dynamic call targets - (callinsns,_cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- stdcall has callee do it, but is not supported on + -- x86_64 target (see #3336) + (if real_size==0 then [] else + [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + -- in + setDeltaNat (delta + real_size) - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- stdcall has callee do it, but is not supported on - -- x86_64 target (see #3336) - (if real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - -- in - setDeltaNat (delta + real_size) + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (load_args_code `appOL` - adjust_rsp `appOL` - push_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) - where - arg_size = 8 -- always, at the mo + where arg_size = 8 -- always, at the mo load_args :: [CmmHinted CmmExpr] -> [Reg] -- int regs avail for args @@ -2051,10 +2171,14 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported here" + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_Add2 {} -> unsupported + MO_U_Mul2 {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ "not supported here") -- ----------------------------------------------------------------------------- -- Generating a table-branch diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 6cd218cc1e..18adee9915 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -188,6 +188,7 @@ data Instr | SUB Size Operand Operand | MUL Size Operand Operand + | MUL2 Size Operand -- %edx:%eax = operand * %rax | IMUL Size Operand Operand -- signed int mul | IMUL2 Size Operand -- %edx:%eax = operand * %eax @@ -332,6 +333,7 @@ x86_regUsageOfInstr instr IMUL _ src dst -> usageRM src dst IMUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] MUL _ src dst -> usageRM src dst + MUL2 _ src -> mkRU (eax:use_R src []) [eax,edx] DIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] IDIV _ op -> mkRU (eax:edx:use_R op []) [eax,edx] AND _ src dst -> usageRM src dst @@ -473,6 +475,7 @@ x86_patchRegsOfInstr instr env IMUL sz src dst -> patch2 (IMUL sz) src dst IMUL2 sz src -> patch1 (IMUL2 sz) src MUL sz src dst -> patch2 (MUL sz) src dst + MUL2 sz src -> patch1 (MUL2 sz) src IDIV sz op -> patch1 (IDIV sz) op DIV sz op -> patch1 (DIV sz) op AND sz src dst -> patch2 (AND sz) src dst diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index f2560fb697..ffed2ec44a 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -609,6 +609,7 @@ pprInstr platform (IMUL2 sz op) = pprSizeOp platform (sLit "imul") sz op -- x86_64 only pprInstr platform (MUL size op1 op2) = pprSizeOpOp platform (sLit "mul") size op1 op2 +pprInstr platform (MUL2 size op) = pprSizeOp platform (sLit "mul") size op pprInstr platform (FDIV size op1 op2) = pprSizeOpOp platform (sLit "div") size op1 op2 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 6e74cfbc4a..74da99a005 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -487,6 +487,7 @@ data Token | ITvect_prag | ITvect_scalar_prag | ITnovect_prag + | ITctype | ITdotdot -- reserved symbols | ITcolon @@ -2287,7 +2288,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("nounpack", token ITnounpack_prag), ("ann", token ITann_prag), ("vectorize", token ITvect_prag), - ("novectorize", token ITnovect_prag)]) + ("novectorize", token ITnovect_prag), + ("ctype", token ITctype)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 61eb5748a3..35f8e487ab 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -38,9 +38,7 @@ import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataC unboxedUnitTyCon, unboxedUnitDataCon, listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) import Type ( funTyCon ) -import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, - CCallConv(..), CCallTarget(..), defaultCCallConv - ) +import ForeignCall import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc @@ -269,6 +267,7 @@ incorrect. '{-# VECTORISE' { L _ ITvect_prag } '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } '{-# NOVECTORISE' { L _ ITnovect_prag } + '{-# CTYPE' { L _ ITctype } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -631,18 +630,18 @@ ty_decl :: { LTyClDecl RdrName } {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) } -- ordinary data type or newtype declaration - | data_or_newtype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2 - Nothing (reverse (unLoc $3)) (unLoc $4) } + | data_or_newtype capi_ctype tycl_hdr constrs deriving + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) False $2 $3 + Nothing (reverse (unLoc $4)) (unLoc $5) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- ordinary GADT declaration - | data_or_newtype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 - (unLoc $3) (unLoc $4) (unLoc $5) } + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) False $2 $3 + (unLoc $4) (unLoc $5) (unLoc $6) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -664,7 +663,7 @@ inst_decl :: { LInstDecl RdrName } -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving - {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3 + {% do { L loc d <- mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True Nothing $3 Nothing (reverse (unLoc $4)) (unLoc $5) ; return (L loc (FamInstDecl d)) } } @@ -672,7 +671,7 @@ inst_decl :: { LInstDecl RdrName } | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving - {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + {% do { L loc d <- mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True Nothing $3 (unLoc $4) (unLoc $5) (unLoc $6) ; return (L loc (FamInstDecl d)) } } @@ -689,7 +688,7 @@ at_decl_cls :: { LTyClDecl RdrName } -- type family declarations : 'type' type opt_kind_sig -- Note the use of type for the head; this allows - -- infix type constructors to be declared + -- infix type constructors to be declared. {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) } -- default type instance @@ -712,16 +711,16 @@ at_decl_inst :: { LTyClDecl RdrName } {% mkTySynonym (comb2 $1 $4) True $2 $4 } -- data/newtype instance declaration - | data_or_newtype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2 - Nothing (reverse (unLoc $3)) (unLoc $4) } + | data_or_newtype capi_ctype tycl_hdr constrs deriving + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $2 $3 + Nothing (reverse (unLoc $4)) (unLoc $5) } -- GADT instance declaration - | data_or_newtype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2 - (unLoc $3) (unLoc $4) (unLoc $5) } + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $2 $3 + (unLoc $4) (unLoc $5) (unLoc $6) } data_or_newtype :: { Located NewOrData } : 'data' { L1 DataType } @@ -742,6 +741,11 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } : context '=>' type { LL (Just $1, $3) } | type { L1 (Nothing, $1) } +capi_ctype :: { Maybe CType } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) } + | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } + | { Nothing } + ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -871,7 +875,7 @@ rule_var_list :: { [RuleBndr RdrName] } rule_var :: { RuleBndr RdrName } : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } + | '(' varid '::' ctype ')' { RuleBndrSig $2 (HsBSig $4 placeHolderBndrs) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1104,7 +1108,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } tv_bndr :: { LHsTyVarBndr RdrName } : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4 placeHolderKind) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (HsBSig $4 placeHolderBndrs) placeHolderKind) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1137,6 +1141,7 @@ akind :: { LHsKind RdrName } : '*' { L1 $ HsTyVar (nameRdrName liftedTypeKindTyConName) } | '(' kind ')' { LL $ HsParTy $2 } | pkind { $1 } + | tyvar { L1 $ HsTyVar (unLoc $1) } pkind :: { LHsKind RdrName } -- promoted type, see Note [Promotion] : qtycon { L1 $ HsTyVar $ unLoc $1 } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 3a786ea04b..872bcdefc0 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -278,7 +278,7 @@ exp :: { IfaceExpr } -- "InlineMe" -> IfaceNote IfaceInlineMe $3 -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2) Nothing) + (CCallSpec (StaticTarget (mkFastString $2) Nothing True) CCallConv PlaySafe)) $3 } @@ -375,7 +375,9 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toHsKind k) placeHolderKind +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig placeHolderKind + where + bsig = HsBSig (toHsKind k) placeHolderBndrs ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 8900f9fdec..9c000ee765 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -200,18 +200,20 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls mkTyData :: SrcSpan -> NewOrData -> Bool -- True <=> data family instance + -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) -mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data is_family cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr ; checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams - ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc, + ; return (L loc (TyData { tcdND = new_or_data, tcdCType = cType, + tcdCtxt = cxt, tcdLName = tc, tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = data_cons, tcdKindSig = ksig, tcdDerivs = maybe_deriv })) } @@ -224,7 +226,9 @@ mkTySynonym :: SrcSpan mkTySynonym loc is_family lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs ; (tyvars, typats) <- checkTParams is_family lhs tparams - ; return (L loc (TySynonym tc tyvars typats rhs)) } + ; return (L loc (TySynonym { tcdLName = tc + , tcdTyVars = tyvars, tcdTyPats = typats + , tcdSynRhs = rhs, tcdFVs = placeHolderNames })) } mkTyFamily :: SrcSpan -> FamilyFlavour @@ -505,7 +509,7 @@ checkTyVars tycl_hdr tparms = mapM chk tparms where -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k placeHolderKind)) + | isRdrTyVar tv = return (L l (KindedTyVar tv (HsBSig k placeHolderBndrs) placeHolderKind)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) chk t@(L l _) @@ -642,7 +646,7 @@ checkAPat dynflags loc e0 = case e0 of let t' = case t of L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty other -> other - return (SigPatIn e t') + return (SigPatIn e (HsBSig t' placeHolderBndrs)) -- n+k patterns OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ @@ -920,8 +924,8 @@ mkImport :: CCallConv -> P (HsDecl RdrName) mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (StaticTarget entity Nothing) - importSpec = CImport PrimCallConv safety nilFS funcTarget + let funcTarget = CFunction (StaticTarget entity Nothing True) + importSpec = CImport PrimCallConv safety Nothing funcTarget return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do @@ -941,27 +945,45 @@ parseCImport cconv safety nm str = parse = do skipSpaces r <- choice [ - string "dynamic" >> return (mk nilFS (CFunction DynamicTarget)), - string "wrapper" >> return (mk nilFS CWrapper), - optional (string "static" >> skipSpaces) >> - (mk nilFS <$> cimp nm) +++ - (do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm) + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + mk (Just (Header (mkFastString h))) <$> cimp nm)) ] skipSpaces return r + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + mk = CImport cconv safety hdr_char c = not (isSpace c) -- header files are filenames, which can contain -- pretty much any char (depending on the platform), -- so just accept any non-space character - id_char c = isAlphaNum c || c == '_' + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) + +++ (do isFun <- case cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget cid' Nothing isFun))) where cid = return nm +++ - (do c <- satisfy (\c -> isAlpha c || c == '_') + (do c <- satisfy id_first_char cs <- many (satisfy id_char) return (mkFastString (c:cs))) diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index f959fb08d4..b3a2ad3ff1 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -14,6 +14,8 @@ module ForeignCall ( CCallSpec(..), CCallTarget(..), isDynamicTarget, CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), ) where import FastString @@ -125,6 +127,9 @@ data CCallTarget -- The first argument of the import is the name of a function pointer (an Addr#). -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports | DynamicTarget deriving( Eq, Data, Typeable ) @@ -217,16 +222,39 @@ instance Outputable CCallSpec where gc_suf | playSafe safety = text "_GC" | otherwise = empty - ppr_fun (StaticTarget fn Nothing) - = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn - - ppr_fun (StaticTarget fn (Just pkgId)) - = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn + ppr_fun (StaticTarget fn mPkgId isFun) + = text (if isFun then "__pkg_ccall" + else "__pkg_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <+> pprCLabelString fn ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" \end{code} +\begin{code} +-- The filename for a C header file +newtype Header = Header FastString + deriving (Eq, Data, Typeable) + +instance Outputable Header where + ppr (Header h) = quotes $ ppr h + +-- | A C type, used in CAPI FFI calls +data CType = CType (Maybe Header) -- header to include for this type + FastString -- the type itself + deriving (Data, Typeable) + +instance Outputable CType where + ppr (CType mh ct) = hDoc <+> ftext ct + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h +\end{code} + %************************************************************************ %* * @@ -275,10 +303,11 @@ instance Binary CCallSpec where return (CCallSpec aa ab ac) instance Binary CCallTarget where - put_ bh (StaticTarget aa ab) = do + put_ bh (StaticTarget aa ab ac) = do putByte bh 0 put_ bh aa put_ bh ab + put_ bh ac put_ bh DynamicTarget = do putByte bh 1 get bh = do @@ -286,7 +315,8 @@ instance Binary CCallTarget where case h of 0 -> do aa <- get bh ab <- get bh - return (StaticTarget aa ab) + ac <- get bh + return (StaticTarget aa ab ac) _ -> do return DynamicTarget instance Binary CCallConv where @@ -308,4 +338,16 @@ instance Binary CCallConv where 2 -> do return PrimCallConv 3 -> do return CmmCallConv _ -> do return CApiConv + +instance Binary CType where + put_ bh (CType mh fs) = do put_ bh mh + put_ bh fs + get bh = do mh <- get bh + fs <- get bh + return (CType mh fs) + +instance Binary Header where + put_ bh (Header h) = put_ bh h + get bh = do h <- get bh + return (Header h) \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index aa04fe7090..35806a1dc6 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1286,8 +1286,8 @@ eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors -tySuperKindTyConKey :: Unique -tySuperKindTyConKey = mkPreludeTyConUnique 85 +superKindTyConKey :: Unique +superKindTyConKey = mkPreludeTyConUnique 85 -- Kind constructors liftedTypeKindTyConKey, anyKindTyConKey, openTypeKindTyConKey, @@ -1657,25 +1657,6 @@ mzipIdKey = mkPreludeMiscIdUnique 196 ----------------------------------------------------- \end{code} - -%************************************************************************ -%* * -\subsection{Standard groups of types} -%* * -%************************************************************************ - -\begin{code} -kindKeys :: [Unique] -kindKeys = [ anyKindTyConKey - , liftedTypeKindTyConKey - , openTypeKindTyConKey - , unliftedTypeKindTyConKey - , ubxTupleKindTyConKey - , argTypeKindTyConKey - , constraintKindTyConKey ] -\end{code} - - %************************************************************************ %* * \subsection[Class-std-groups]{Standard groups of Prelude classes} diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 7634089ded..89181e89cb 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -25,11 +25,11 @@ module TysPrim( kKiVar, -- Kind constructors... - tySuperKindTyCon, tySuperKind, anyKindTyCon, + superKindTyCon, superKind, anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, constraintKindTyCon, - tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, + superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName, @@ -132,7 +132,6 @@ primTyCons , word32PrimTyCon , word64PrimTyCon , anyTyCon - , anyKindTyCon , eqPrimTyCon , liftedTypeKindTyCon @@ -141,6 +140,8 @@ primTyCons , argTypeKindTyCon , ubxTupleKindTyCon , constraintKindTyCon + , superKindTyCon + , anyKindTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -233,7 +234,7 @@ argAlphaTy = mkTyVarTy argAlphaTyVar argBetaTy = mkTyVarTy argBetaTyVar kKiVar :: KindVar -kKiVar = (tyVarList tySuperKind) !! 10 +kKiVar = (tyVarList superKind) !! 10 \end{code} @@ -282,33 +283,53 @@ funTyCon = mkFunTyCon funTyConName $ %* * %************************************************************************ +Note [SuperKind (BOX)] +~~~~~~~~~~~~~~~~~~~~~~ +Kinds are classified by "super-kinds". There is only one super-kind, namely BOX. + +Perhaps surprisingly we give BOX the kind BOX, thus BOX :: BOX +Reason: we want to have kind equalities, thus (without the kind applications) + keq :: * ~ * = Eq# <refl *> +Remember that + (~) :: forall (k:BOX). k -> k -> Constraint + (~#) :: forall (k:BOX). k -> k -> # + Eq# :: forall (k:BOX). forall (a:k) (b:k). (~#) k a b -> (~) k a b + +So the full defn of keq is + keq :: (~) BOX * * = Eq# BOX * * <refl *> + +So you can see it's convenient to have BOX:BOX + + \begin{code} -- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -tySuperKindTyCon, anyKindTyCon, liftedTypeKindTyCon, +superKindTyCon, anyKindTyCon, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, ubxTupleKindTyCon, argTypeKindTyCon, constraintKindTyCon :: TyCon -tySuperKindTyConName, anyKindTyConName, liftedTypeKindTyConName, +superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, openTypeKindTyConName, unliftedTypeKindTyConName, ubxTupleKindTyConName, argTypeKindTyConName, constraintKindTyConName :: Name -tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName -anyKindTyCon = mkKindTyCon anyKindTyConName tySuperKind -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind -constraintKindTyCon = mkKindTyCon constraintKindTyConName tySuperKind +superKindTyCon = mkKindTyCon superKindTyConName superKind + -- See Note [SuperKind (BOX)] + +anyKindTyCon = mkKindTyCon anyKindTyConName superKind +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind +ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName superKind +argTypeKindTyCon = mkKindTyCon argTypeKindTyConName superKind +constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind -------------------------- -- ... and now their names -tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon -anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon +superKindTyConName = mkPrimTyConName (fsLit "BOX") superKindTyConKey superKindTyCon +anyKindTyConName = mkPrimTyConName (fsLit "AnyK") anyKindTyConKey anyKindTyCon liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon openTypeKindTyConName = mkPrimTyConName (fsLit "OpenKind") openTypeKindTyConKey openTypeKindTyCon unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon @@ -331,10 +352,12 @@ kindTyConType :: TyCon -> Type kindTyConType kind = TyConApp kind [] -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind :: Kind +anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, constraintKind, + superKind :: Kind --- See Note [Any kinds] -anyKind = kindTyConType anyKindTyCon +superKind = kindTyConType superKindTyCon +anyKind = kindTyConType anyKindTyCon -- See Note [Any kinds] liftedTypeKind = kindTyConType liftedTypeKindTyCon unliftedTypeKind = kindTyConType unliftedTypeKindTyCon openTypeKind = kindTyConType openTypeKindTyCon @@ -343,10 +366,10 @@ ubxTupleKind = kindTyConType ubxTupleKindTyCon constraintKind = kindTyConType constraintKindTyCon typeNatKind :: Kind -typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName tySuperKind) +typeNatKind = kindTyConType (mkKindTyCon typeNatKindConName superKind) typeStringKind :: Kind -typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName tySuperKind) +typeStringKind = kindTyConType (mkKindTyCon typeStringKindConName superKind) -- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ mkArrowKind :: Kind -> Kind -> Kind @@ -355,9 +378,6 @@ mkArrowKind k1 k2 = FunTy k1 k2 -- | Iterated application of 'mkArrowKind' mkArrowKinds :: [Kind] -> Kind -> Kind mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds - -tySuperKind :: SuperKind -tySuperKind = kindTyConType tySuperKindTyCon \end{code} %************************************************************************ @@ -464,7 +484,7 @@ keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy :: Type -> Type -mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] +mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty] statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep @@ -510,17 +530,17 @@ arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRe mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = mkTyConApp arrayPrimTyCon [elt] +mkArrayPrimTy elt = mkNakedTyConApp arrayPrimTyCon [elt] byteArrayPrimTy :: Type byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon mkArrayArrayPrimTy :: Type mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = mkTyConApp mutableArrayPrimTyCon [s, elt] +mkMutableArrayPrimTy s elt = mkNakedTyConApp mutableArrayPrimTyCon [s, elt] mkMutableByteArrayPrimTy :: Type -> Type -mkMutableByteArrayPrimTy s = mkTyConApp mutableByteArrayPrimTyCon [s] +mkMutableByteArrayPrimTy s = mkNakedTyConApp mutableByteArrayPrimTyCon [s] mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = mkTyConApp mutableArrayArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s] \end{code} %************************************************************************ @@ -534,7 +554,7 @@ mutVarPrimTyCon :: TyCon mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = mkTyConApp mutVarPrimTyCon [s, elt] +mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -548,7 +568,7 @@ mVarPrimTyCon :: TyCon mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = mkTyConApp mVarPrimTyCon [s, elt] +mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -562,7 +582,7 @@ tVarPrimTyCon :: TyCon tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = mkTyConApp tVarPrimTyCon [s, elt] +mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -576,7 +596,7 @@ stablePtrPrimTyCon :: TyCon stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = mkTyConApp stablePtrPrimTyCon [ty] +mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty] \end{code} %************************************************************************ @@ -590,7 +610,7 @@ stableNamePrimTyCon :: TyCon stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = mkTyConApp stableNamePrimTyCon [ty] +mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty] \end{code} %************************************************************************ @@ -617,7 +637,7 @@ weakPrimTyCon :: TyCon weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = mkTyConApp weakPrimTyCon [v] +mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v] \end{code} %************************************************************************ @@ -718,5 +738,5 @@ anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp anyTyCon [kind] +anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] \end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 162a7025c0..4b7f043adb 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -54,8 +54,8 @@ module TysWiredIn ( -- * Tuples mkTupleTy, mkBoxedTupleTy, - tupleTyCon, promotedTupleTyCon, - tupleCon, + tupleTyCon, tupleCon, + promotedTupleTyCon, promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, unboxedSingletonTyCon, unboxedSingletonDataCon, @@ -88,6 +88,7 @@ import TysPrim import Coercion import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) +import Type ( mkTyConApp ) import DataCon import Var import TyCon @@ -96,6 +97,7 @@ import RdrName import Name import BasicTypes ( TupleSort(..), tupleSortBoxity, IPName(..), Arity, RecFlag(..), Boxity(..), HsBang(..) ) +import ForeignCall import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array @@ -229,18 +231,19 @@ eqTyCon_RDR = nameRdrName eqTyConName %************************************************************************ \begin{code} -pcNonRecDataTyCon :: Name -> [TyVar] -> [DataCon] -> TyCon +pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcNonRecDataTyCon = pcTyCon False NonRecursive -pcRecDataTyCon :: Name -> [TyVar] -> [DataCon] -> TyCon +pcRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcRecDataTyCon = pcTyCon False Recursive -pcTyCon :: Bool -> RecFlag -> Name -> [TyVar] -> [DataCon] -> TyCon -pcTyCon is_enum is_rec name tyvars cons +pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon is_enum is_rec name cType tyvars cons = tycon where tycon = mkAlgTyCon name (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars + cType [] -- No stupid theta (DataTyCon cons is_enum) NoParentTyCon @@ -326,6 +329,9 @@ tupleTyCon ConstraintTuple i = fst (factTupleArr ! i) promotedTupleTyCon :: TupleSort -> Arity -> TyCon promotedTupleTyCon sort i = buildPromotedTyCon (tupleTyCon sort i) +promotedTupleDataCon :: TupleSort -> Arity -> TyCon +promotedTupleDataCon sort i = buildPromotedDataCon (tupleCon 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) @@ -406,6 +412,7 @@ mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u = name_ip tycon = mkAlgTyCon tycon_name (liftedTypeKind `mkArrowKind` constraintKind) [alphaTyVar] + Nothing [] -- No stupid theta (NewTyCon { data_con = datacon, nt_rhs = mkTyVarTy alphaTyVar, @@ -432,6 +439,7 @@ eqTyCon :: TyCon eqTyCon = mkAlgTyCon eqTyConName (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) [kv, a, b] + Nothing [] -- No stupid theta (DataTyCon [eqBoxDataCon] False) NoParentTyCon @@ -456,7 +464,8 @@ charTy :: Type charTy = mkTyConTy charTyCon charTyCon :: TyCon -charTyCon = pcNonRecDataTyCon charTyConName [] [charDataCon] +charTyCon = pcNonRecDataTyCon charTyConName (Just (CType Nothing (fsLit "HsChar"))) + [] [charDataCon] charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon @@ -468,7 +477,7 @@ stringTy = mkListTy charTy -- convenience only integerTyCon :: TyCon integerTyCon = case cIntegerLibraryType of IntegerGMP -> - pcNonRecDataTyCon integerRealTyConName [] + pcNonRecDataTyCon integerRealTyConName Nothing [] [integerGmpSDataCon, integerGmpJDataCon] _ -> panic "Evaluated integerTyCon, but not using IntegerGMP" @@ -491,7 +500,7 @@ intTy :: Type intTy = mkTyConTy intTyCon intTyCon :: TyCon -intTyCon = pcNonRecDataTyCon intTyConName [] [intDataCon] +intTyCon = pcNonRecDataTyCon intTyConName (Just (CType Nothing (fsLit "HsInt"))) [] [intDataCon] intDataCon :: DataCon intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon \end{code} @@ -501,7 +510,7 @@ wordTy :: Type wordTy = mkTyConTy wordTyCon wordTyCon :: TyCon -wordTyCon = pcNonRecDataTyCon wordTyConName [] [wordDataCon] +wordTyCon = pcNonRecDataTyCon wordTyConName (Just (CType Nothing (fsLit "HsWord"))) [] [wordDataCon] wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon \end{code} @@ -511,7 +520,7 @@ floatTy :: Type floatTy = mkTyConTy floatTyCon floatTyCon :: TyCon -floatTyCon = pcNonRecDataTyCon floatTyConName [] [floatDataCon] +floatTyCon = pcNonRecDataTyCon floatTyConName (Just (CType Nothing (fsLit "HsFloat"))) [] [floatDataCon] floatDataCon :: DataCon floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon \end{code} @@ -521,7 +530,7 @@ doubleTy :: Type doubleTy = mkTyConTy doubleTyCon doubleTyCon :: TyCon -doubleTyCon = pcNonRecDataTyCon doubleTyConName [] [doubleDataCon] +doubleTyCon = pcNonRecDataTyCon doubleTyConName (Just (CType Nothing (fsLit "HsDouble"))) [] [doubleDataCon] doubleDataCon :: DataCon doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon @@ -582,7 +591,8 @@ boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon boolTyCon = pcTyCon True NonRecursive boolTyConName - [] [falseDataCon, trueDataCon] + (Just (CType Nothing (fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] falseDataCon, trueDataCon :: DataCon falseDataCon = pcDataCon falseDataConName [] [] boolTyCon @@ -593,7 +603,7 @@ falseDataConId = dataConWorkId falseDataCon trueDataConId = dataConWorkId trueDataCon orderingTyCon :: TyCon -orderingTyCon = pcTyCon True NonRecursive orderingTyConName +orderingTyCon = pcTyCon True NonRecursive orderingTyConName Nothing [] [ltDataCon, eqDataCon, gtDataCon] ltDataCon, eqDataCon, gtDataCon :: DataCon @@ -627,7 +637,7 @@ mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon -listTyCon = pcRecDataTyCon listTyConName alpha_tyvar [nilDataCon, consDataCon] +listTyCon = pcRecDataTyCon listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon] mkPromotedListTy :: Type -> Type mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] @@ -729,7 +739,7 @@ mkPArrTy ty = mkTyConApp parrTyCon [ty] -- @PrelPArr@. -- parrTyCon :: TyCon -parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [parrDataCon] +parrTyCon = pcNonRecDataTyCon parrTyConName Nothing alpha_tyvar [parrDataCon] parrDataCon :: DataCon parrDataCon = pcDataCon diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 48dd76873a..4d452c02ea 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -210,6 +210,11 @@ primop IntRemOp "remInt#" Dyadic {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} with can_fail = True +primop IntQuotRemOp "quotRemInt#" GenPrimOp + Int# -> Int# -> (# Int#, Int# #) + {Rounds towards zero.} + with can_fail = True + primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; @@ -264,17 +269,29 @@ primtype Word# primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# with commutable = True +primop WordAdd2Op "plusWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# with commutable = True +primop WordMul2Op "timesWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# with can_fail = True primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# with can_fail = True +primop WordQuotRemOp "quotRemWord#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with can_fail = True + primop AndOp "and#" Dyadic Word# -> Word# -> Word# with commutable = True diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 969a517629..6a7bfbea9a 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -33,10 +33,9 @@ module RnBinds ( import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import RnHsSyn import TcRnMonad import TcEvidence ( emptyTcEvBinds ) -import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch ) +import RnTypes ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch ) import RnPat import RnEnv import DynFlags @@ -184,8 +183,8 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; sigs' <- renameSigs HsBootCtxt sigs - ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } + ; (sigs', fvs) <- renameSigs HsBootCtxt sigs + ; return (ValBindsOut [] sigs', usesOnly fvs) } rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -291,13 +290,13 @@ rnValBindsRHS :: HsSigCtxt -> RnM (HsValBinds Name, DefUses) rnValBindsRHS ctxt (ValBindsIn mbinds sigs) - = do { sigs' <- renameSigs ctxt sigs + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds ; case depAnalBinds binds_w_dus of (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs') + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs -- Put the sig uses *after* the bindings -- so that the binders are removed from -- the uses in the sigs @@ -649,7 +648,7 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigs :: HsSigCtxt -> [LSig RdrName] - -> RnM [LSig Name] + -> RnM ([LSig Name], FreeVars) -- Renames the signatures and performs error checks renameSigs ctxt sigs = do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs) -- Duplicate @@ -662,12 +661,12 @@ renameSigs ctxt sigs -- op :: a -> a -- default op :: Eq a => a -> a - ; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' ; mapM_ misplacedSigErr bad_sigs -- Misplaced - ; return good_sigs } + ; return (good_sigs, sig_fvs) } ---------------------- -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory @@ -679,26 +678,26 @@ renameSigs ctxt sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name) +renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) - = return (IdSig x) -- Actually this never occurs + = return (IdSig x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (TypeSig new_vs new_ty) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (TypeSig new_vs new_ty, fvs) } renameSig ctxt sig@(GenericSig vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures ; unless defaultSigs_on (addErr (defaultSigErr sig)) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty - ; return (GenericSig new_v new_ty) } + ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (GenericSig new_v new_ty, fvs) } renameSig _ (SpecInstSig ty) - = do { new_ty <- rnLHsType SpecInstSigCtx ty - ; return (SpecInstSig new_ty) } + = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty + ; return (SpecInstSig new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -708,16 +707,16 @@ renameSig ctxt sig@(SpecSig v ty inl) = do { new_v <- case ctxt of TopSigCtxt -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (SpecSig new_v new_ty inl) } + ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty + ; return (SpecSig new_v new_ty inl, fvs) } renameSig ctxt sig@(InlineSig v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig new_v s) } + ; return (InlineSig new_v s, emptyFVs) } renameSig ctxt sig@(FixSig (FixitySig v f)) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (FixSig (FixitySig new_v f)) } + ; return (FixSig (FixitySig new_v f), emptyFVs) } ppr_sig_bndrs :: [Located RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) @@ -778,7 +777,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss ; return (Match pats' Nothing grhss', grhss_fvs) }} - -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc resSigErr ctxt match ty diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index ecd2cd3147..f1adba6bd3 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -14,13 +14,16 @@ module RnEnv ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, - lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocalOccRn_maybe, + lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndrOcc, greRdrName, + lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName, + greRdrName, lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -31,7 +34,6 @@ module RnEnv ( MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, - bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, extendTyVarEnvFVRn, checkDupRdrNames, checkDupAndShadowedRdrNames, @@ -40,7 +42,6 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext ) where @@ -49,7 +50,6 @@ module RnEnv ( import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv import HsSyn -import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName import HscTypes import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) @@ -72,7 +72,6 @@ import ListSetOps ( removeDups ) import DynFlags import FastString import Control.Monad -import Data.List import qualified Data.Set as Set \end{code} @@ -271,6 +270,25 @@ lookupInstDeclBndr cls what rdr where doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls) + +----------------------------------------------- +lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) +-- 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 + = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this + lookupLocatedTopBndrRn tc_rdr + + | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr + + | otherwise -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + where + tc_rdr = tcdLName tc_decl + ----------------------------------------------- lookupConstructorFields :: Name -> RnM [Name] -- Look up the fields of a given constructor @@ -374,6 +392,40 @@ lookupSubBndrGREs env parent rdr_name parent_is _ _ = False \end{code} +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurence +of 'G' in the 'instance C S' decl is unambiguous, becuase C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + Note [Looking up Exact RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Exact RdrNames are generated by Template Haskell. See Note [Binders @@ -452,10 +504,18 @@ lookupOccRn rdr_name = do opt_name <- lookupOccRn_maybe rdr_name maybe (unboundName WL_Any rdr_name) return opt_name +lookupKindOccRn :: RdrName -> RnM Name +-- Looking up a name occurring in a kind +lookupKindOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName WL_Any rdr_name } + -- lookupPromotedOccRn looks up an optionally promoted RdrName. -lookupPromotedOccRn :: RdrName -> RnM Name +lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] -lookupPromotedOccRn rdr_name +lookupTypeOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of { Just name -> return name ; @@ -1018,42 +1078,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope return (thing, delFVs names fvs) ------------------------------------- -bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a - -- Find the type variables in the pattern type - -- signatures that must be brought into scope -bindPatSigTyVars tys thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside [] - else - do { name_env <- getLocalRdrEnv - ; let locd_tvs = [ tv | ty <- tys - , tv <- extractHsTyRdrTyVars ty - , not (unLoc tv `elemLocalRdrEnv` name_env) ] - nubbed_tvs = nubBy eqLocated locd_tvs - -- The 'nub' is important. For example: - -- f (x :: t) (y :: t) = .... - -- We don't want to complain about binding t twice! - - ; bindLocatedLocalsRn nubbed_tvs thing_inside }} - -bindPatSigTyVarsFV :: [LHsType RdrName] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) -bindPatSigTyVarsFV tys thing_inside - = bindPatSigTyVars tys $ \ tvs -> - thing_inside `thenM` \ (result,fvs) -> - return (result, fvs `delListFromNameSet` tvs) - -bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) -bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This function is used only in rnSourceDecl on InstDecl @@ -1148,24 +1172,19 @@ 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 $$ extra + ; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + err = unknownNameErr what rdr_name $$ extra ; if not show_helpful_errors then addErr err else do { suggestions <- unknownNameSuggestErr where_look rdr_name ; addErr (err $$ suggestions) } - ; env <- getGlobalRdrEnv; - ; traceRn (vcat [unknownNameErr rdr_name, - ptext (sLit "Global envt is:"), - nest 3 (pprGlobalRdrEnv env)]) - ; return (mkUnboundName rdr_name) } -unknownNameErr :: RdrName -> SDoc -unknownNameErr rdr_name +unknownNameErr :: SDoc -> RdrName -> SDoc +unknownNameErr what rdr_name = vcat [ hang (ptext (sLit "Not in scope:")) - 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - <+> quotes (ppr rdr_name)) + 2 (what <+> quotes (ppr rdr_name)) , extra ] where extra | rdr_name == forall_tv_RDR = perhapsForallMsg diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 7caae61027..b884d4abde 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -34,8 +34,7 @@ import HsSyn import TcRnMonad import TcEnv ( thRnBrack ) import RnEnv -import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) +import RnTypes import RnPat import DynFlags import BasicTypes ( FixityDirection(..) ) @@ -270,7 +269,7 @@ rnExpr (RecordUpd expr rbinds _ _ _) fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty + = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ rnLExpr expr ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } @@ -283,7 +282,7 @@ rnExpr (HsIf _ p b1 b2) ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) - = rnHsTypeFVs HsTypeCtx a `thenM` \ (t, fvT) -> + = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) rnExpr (ArithSeq _ seq) @@ -607,7 +606,7 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) -rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t +rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t ; return (TypBr t', fvs) } rnBracket (DecBrL decls) diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs deleted file mode 100644 index 8df896b5a2..0000000000 --- a/compiler/rename/RnHsSyn.lhs +++ /dev/null @@ -1,160 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} - -\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 RnHsSyn( - -- Names - charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, - extractHsTyVars, extractHsTyNames, extractHsTyNames_s, - extractFunDepNames, extractHsCtxtTyNames, - extractHsTyVarBndrNames, extractHsTyVarBndrNames_s, - - -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs - ) where - -#include "HsVersions.h" - -import HsSyn -import Class ( FunDep ) -import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) -import Name ( Name, getName, isTyVarName ) -import NameSet -import BasicTypes ( TupleSort ) -import SrcLoc -import Panic ( panic ) -\end{code} - -%************************************************************************ -%* * -\subsection{Free variables} -%* * -%************************************************************************ - -These free-variable finders returns tycons and classes too. - -\begin{code} -charTyCon_name, listTyCon_name, parrTyCon_name :: Name -charTyCon_name = getName charTyCon -listTyCon_name = getName listTyCon -parrTyCon_name = getName parrTyCon - -tupleTyCon_name :: TupleSort -> Int -> Name -tupleTyCon_name sort n = getName (tupleTyCon sort n) - -extractHsTyVars :: LHsType Name -> NameSet -extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) - -extractFunDepNames :: FunDep Name -> NameSet -extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 - -extractHsTyNames :: LHsType Name -> NameSet --- Also extract names in kinds. -extractHsTyNames ty - = getl ty - where - getl (L _ ty) = get ty - - get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty - get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty - get (HsTupleTy _ tys) = extractHsTyNames_s tys - get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsIParamTy _ ty) = getl ty - get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 - get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) - get (HsParTy ty) = getl ty - get (HsBangTy _ ty) = getl ty - get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) - get (HsTyVar tv) = unitNameSet tv - get (HsSpliceTy _ fvs _) = fvs - get (HsQuasiQuoteTy {}) = emptyNameSet - get (HsKindSig ty ki) = getl ty `unionNameSets` getl ki - get (HsForAllTy _ tvs - ctxt ty) = extractHsTyVarBndrNames_s tvs - (extractHsCtxtTyNames ctxt - `unionNameSets` getl ty) - get (HsDocTy ty _) = getl ty - get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right - -- but I don't think it matters - get (HsExplicitListTy _ tys) = extractHsTyNames_s tys - get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys - get (HsTyLit _) = emptyNameSet - get (HsWrapTy {}) = panic "extractHsTyNames" - -extractHsTyNames_s :: [LHsType Name] -> NameSet -extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys - -extractHsCtxtTyNames :: LHsContext Name -> NameSet -extractHsCtxtTyNames (L _ ctxt) - = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt - -extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet -extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet -extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki - -extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet --- Update the name set 'body' by adding the names in the binders --- kinds and handling scoping. -extractHsTyVarBndrNames_s [] body = body -extractHsTyVarBndrNames_s (b:bs) body = - (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b)) - `unionNameSets` extractHsTyVarBndrNames b -\end{code} - - -%************************************************************************ -%* * -\subsection{Free variables of declarations} -%* * -%************************************************************************ - -Return the Names that must be in scope if we are to use this declaration. -In all cases this is set up for interface-file declarations: - - for class decls we ignore the bindings - - for instance decls likewise, plus the pragmas - - for rule decls, we ignore HsRules - - for data decls, we ignore derivings - - *** See "THE NAMING STORY" in HsDecls **** - -\begin{code} ----------------- -hsSigsFVs :: [LSig Name] -> FreeVars -hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) - -hsSigFVs :: Sig Name -> FreeVars -hsSigFVs (TypeSig _ ty) = extractHsTyNames ty -hsSigFVs (GenericSig _ ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty -hsSigFVs _ = emptyFVs - ----------------- -conDeclFVs :: LConDecl Name -> FreeVars -conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, - con_details = details, con_res = res_ty})) - = extractHsTyVarBndrNames_s tyvars $ - extractHsCtxtTyNames context `plusFV` - conDetailsFVs details `plusFV` - conResTyFVs res_ty - -conResTyFVs :: ResType Name -> FreeVars -conResTyFVs ResTyH98 = emptyFVs -conResTyFVs (ResTyGADT ty) = extractHsTyNames ty - -conDetailsFVs :: HsConDeclDetails Name -> FreeVars -conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) - -bangTyFVs :: LHsType Name -> FreeVars -bangTyFVs bty = extractHsTyNames (getBangType bty) -\end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index b1a61db2a2..553c3ef81a 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -7,7 +7,7 @@ module RnNames ( rnImports, getLocalNonValBinders, rnExports, extendGlobalRdrEnvRn, - gresFromAvails, lookupTcdName, + gresFromAvails, reportUnusedNames, finishWarnings, ) where @@ -528,6 +528,18 @@ getLocalNonValBinders fixity_env ; names@(main_name : _) <- mapM newTopSrcBinder bndrs ; return (AvailTC main_name names) } + new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] + new_assoc (L _ (FamInstDecl d)) + = do { avail <- new_ti Nothing d + ; return [avail] } + new_assoc (L _ (ClsInstDecl inst_ty _ _ ats)) + | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty + = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr + ; mapM (new_ti (Just cls_nm) . unLoc) ats } + | otherwise + = return [] -- Do not crash on ill-formed instances + -- Eg instance !Show Int Trac #3811c + new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo new_ti mb_cls ti_decl -- ONLY for type/data instances = ASSERT( isFamInstDecl ti_decl ) @@ -535,37 +547,6 @@ getLocalNonValBinders fixity_env ; 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 _ (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 . unLoc) ats } - where - get_cls_parent inst_ty - | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty - = setSrcSpan loc $ do { nm <- lookupGlobalOccRn cls_rdr; return (Just nm) } - | otherwise - = return Nothing - -lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) --- 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 - = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this - lookupLocatedTopBndrRn tc_rdr - - | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind - = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr - - | otherwise -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRn tc_rdr - where - tc_rdr = tcdLName tc_decl \end{code} Note [Looking up family names in family instances] @@ -586,41 +567,6 @@ Solution is simple: process the type family declarations first, extend the environment, and then process the type instances. -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurence -of 'G' in the 'instance C S' decl is unambiguous, becuase C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the encloseing instance decl, if any. - - %************************************************************************ %* * \subsection{Filtering imports} diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 7dd76bd4e6..d0302a19a2 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -162,6 +162,10 @@ matchNameMaker ctxt = LamMk report_unused StmtCtxt GhciStmt -> False _ -> True +rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name)) +rnHsSigCps sig + = CpsRn (rnHsBndrSig True PatCtx sig) + newPatName :: NameMaker -> Located RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> @@ -232,11 +236,9 @@ rnPats :: HsMatchContext Name -- for error messages rnPats ctxt pats thing_inside = do { envs_before <- getRdrEnvs - -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. - ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names -- Must do this *after* renaming the patterns -- See Note [Collect binders only after renaming] in HsUtils @@ -310,15 +312,10 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPatIn pat ty) - = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables) - ; if patsigs - then do { pat' <- rnLPatAndThen mk pat - ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty) - ; return (SigPatIn pat' ty') } - else do { liftCps (addErr (patSigErr ty)) - ; rnPatAndThen mk (unLoc pat) } } - +rnPatAndThen mk (SigPatIn pat sig) + = do { pat' <- rnLPatAndThen mk pat + ; sig' <- rnHsSigCps sig + ; return (SigPatIn pat' sig') } rnPatAndThen mk (LitPat lit) | HsString s <- lit @@ -505,7 +502,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } = return [] rn_dotdot (Just {}) Nothing _flds -- ".." on record update = do { addErr (badDotDot ctxt); return [] } - rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat + rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match = ASSERT( n == length flds ) do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM Opt_RecordWildCards @@ -529,11 +526,11 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } where rdr = mkRdrUnqual (nameOccName fld) - dot_dot_gres = [ gre + dot_dot_gres = [ head gres | fld <- con_fields , not (fld `elem` present_flds) - , let gres@(gre:_) = lookupGRE_Name rdr_env fld - , not (null gres) + , let gres = lookupGRE_Name rdr_env fld + , not (null gres) -- Check field is in scope , case ctxt of HsRecFieldCon {} -> arg_in_scope fld _other -> True ] diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 54f95016c7..a4a734cca1 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -25,7 +25,6 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) import HsSyn import RdrName import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn import RnTypes import RnBinds import RnEnv @@ -43,6 +42,7 @@ import NameEnv import Avail import Outputable import Bag +import BasicTypes ( RuleName ) import FastString import Util ( filterOut ) import SrcLoc @@ -54,7 +54,6 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) import Control.Monad import Data.List( partition ) import Maybes( orElse ) -import Data.Maybe( isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -356,7 +355,7 @@ rnAnnProvenance provenance = do \begin{code} rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) rnDefaultDecl (DefaultDecl tys) - = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys + = do { (tys', fvs) <- rnLHsTypes doc_str tys ; return (DefaultDecl tys', fvs) } where doc_str = DefaultDeclCtx @@ -373,7 +372,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) rnHsForeignDecl (ForeignImport name ty _ spec) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package ; let packageId = thisPackage $ hsc_dflags topEnv @@ -383,7 +382,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec) rnHsForeignDecl (ForeignExport name ty _ spec) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty + ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, @@ -407,8 +406,8 @@ patchCImportSpec packageId spec patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget patchCCallTarget packageId callTarget = case callTarget of - StaticTarget label Nothing - -> StaticTarget label (Just packageId) + StaticTarget label Nothing isFun + -> StaticTarget label (Just packageId) isFun _ -> callTarget @@ -430,18 +429,19 @@ rnSrcInstDecl (FamInstDecl ty_decl) 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 + = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags + tv_names = hsLTyVarNames inst_tyvars -- Rename the associated types, and type signatures -- Both need to have the instance type variables in scope ; ((ats', other_sigs'), more_fvs) - <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $ - do { (ats', at_fvs) <- rnATInsts cls ats - ; other_sigs' <- renameSigs (InstDeclCtxt cls) other_sigs + <- extendTyVarEnvFVRn tv_names $ + do { (ats', at_fvs) <- rnATDecls cls tv_names ats + ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', other_sigs') - , at_fvs `plusFV` hsSigsFVs other_sigs') } + , at_fvs `plusFV` sig_fvs) } -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -458,16 +458,14 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} -- works OK. That's why we did the partition game above -- - -- But the (unqualified) method names are in scope --- ; let binders = collectHsBindsBinders mbinds' - ; spec_inst_prags' <- -- bindLocalNames binders $ - renameSigs (InstDeclCtxt cls) spec_inst_prags + ; (spec_inst_prags', spec_inst_fvs) + <- renameSigs (InstDeclCtxt cls) spec_inst_prags ; let uprags' = spec_inst_prags' ++ other_sigs' ; return (ClsInstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` more_fvs - `plusFV` hsSigsFVs spec_inst_prags' - `plusFV` extractHsTyNames inst_ty') } + `plusFV` spec_inst_fvs + `plusFV` inst_fvs) } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. @@ -483,15 +481,18 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats) Renaming of the associated types in instances. \begin{code} -rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) - -- NB: We allow duplicate associated-type decls; - -- See Note [Associated type instances] in TcInstDcls -rnATInsts cls atDecls = rnList rnATInst atDecls - where - rnATInst tydecl@TyData {} = rnTyClDecl (Just cls) tydecl - rnATInst tydecl@TySynonym {} = rnTyClDecl (Just cls) tydecl - rnATInst tydecl = pprPanic "RnSource.rnATInsts: invalid AT instance" - (ppr (tcdName tydecl)) +rnATDecls :: Name -- Class + -> [Name] -- Type variable binders (but NOT kind variables) + -- See Note [Renaming associated types] in RnTypes + -> [LTyClDecl RdrName] + -> RnM ([LTyClDecl Name], FreeVars) +-- Used for the family declarations and defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in TcInstDcls +rnATDecls cls tvs atDecls + = rnList (rnTyClDecl (Just (cls, tvs))) atDecls \end{code} For the method bindings in class and instance decls, we extend the @@ -520,8 +521,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; ty' <- rnLHsInstType (text "In a deriving declaration") ty - ; let fvs = extractHsTyNames ty' + ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty ; return (DerivDecl ty', fvs) } standaloneDerivErr :: SDoc @@ -539,36 +539,39 @@ standaloneDerivErr \begin{code} rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) - = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV (map get_var vars) $ \ ids -> - do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) - -- NB: The binders in a rule are always Ids - -- We don't (yet) support type variables - - ; (lhs', fv_lhs') <- rnLExpr lhs - ; (rhs', fv_rhs') <- rnLExpr rhs - - ; checkValidRule rule_name ids lhs' fv_lhs' - - ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', - fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') } + = do { let rdr_names_w_loc = map get_var vars + ; checkDupAndShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindHsRuleVars rule_name vars names $ \ vars' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule rule_name names lhs' fv_lhs' + ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_lhs' `plusFV` fv_rhs') } } where - doc = RuleCtx rule_name - - get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v + get_var (RuleBndr v) = v + +bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name] + -> ([RuleBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsRuleVars rule_name vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + doc = RuleCtx rule_name - rn_var (RuleBndr (L loc _), id) - = return (RuleBndr (L loc id), emptyFVs) - rn_var (RuleBndrSig (L loc _) t, id) - = do { (t', fvs) <- rnHsTypeFVs doc t - ; return (RuleBndrSig (L loc id) t', fvs) } + go (RuleBndr (L loc _) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (RuleBndr (L loc n) : vars') -badRuleVar :: FastString -> Name -> SDoc -badRuleVar name var - = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, - ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> - ptext (sLit "does not appear on left hand side")] + go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside + = rnHsBndrSig True doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (RuleBndrSig (L loc n) bsig' : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) \end{code} Note [Rule LHS validity checking] @@ -628,6 +631,12 @@ validRuleLhs foralls lhs checkl_es es = foldr (mplus . checkl_e) Nothing es -} +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon, + ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> + ptext (sLit "does not appear on left hand side")] + badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc badRuleLhsErr name lhs bad_e = sep [ptext (sLit "Rule") <+> ftext name <> colon, @@ -685,8 +694,8 @@ rnHsVectDecl (HsVectClassIn cls) rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" rnHsVectDecl (HsVectInstIn instTy) - = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy - ; return (HsVectInstIn instTy', extractHsTyNames instTy') + = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy + ; return (HsVectInstIn instTy', fvs) } rnHsVectDecl (HsVectInstOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" @@ -772,9 +781,10 @@ rnTyClDecls extra_deps tycl_ds ; return (map flattenSCC sccs, all_fvs) } -rnTyClDecl :: Maybe Name -- Just cls => this TyClDecl is nested - -- inside an *instance decl* for cls - -- used for associated types +rnTyClDecl :: Maybe (Name, [Name]) + -- Just (cls,tvs) => this TyClDecl is nested + -- inside an *instance decl* for cls + -- used for associated types -> TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars) rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) @@ -786,56 +796,52 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- and "data family"), both top level and (for an associated type) -- in a class decl rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars - , tcdFlavour = flav, tcdKind = kind }) - = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' -> + , tcdFlavour = flav, tcdKindSig = kind }) + = bindTyClTyVars fmly_doc mb_cls tyvars $ \tyvars' -> do { tycon' <- lookupLocatedTopBndrRn tycon - ; kind' <- rnLHsMaybeKind fmly_doc kind - ; let fv_kind = maybe emptyFVs extractHsTyNames kind' - fvs = extractHsTyVarBndrNames_s tyvars' fv_kind + ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFlavour = flav, tcdKind = kind' } - , fvs) } - where fmly_doc = TyFamilyCtx tycon + , tcdFlavour = flav, tcdKindSig = kind' } + , fv_kind) } + where + fmly_doc = TyFamilyCtx tycon -- "data", "newtype", "data instance, and "newtype instance" declarations -- both top level and (for an associated type) in an instance decl -rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, +rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType, + tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, tcdTyPats = typats, tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs} - = do { tycon' <- lookupTcdName mb_cls tydecl - ; sig' <- rnLHsMaybeKind data_doc sig + = bindTyClTyVars data_doc mb_cls tyvars $ \ tyvars' -> + -- Checks for distinct tyvars + do { tycon' <- lookupTcdName (fmap fst mb_cls) tydecl ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) - ; ((tyvars', context', typats', derivs'), stuff_fvs) - <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do - -- Checks for distinct tyvars - { context' <- rnContext data_doc context - ; (typats', fvs1) <- rnTyPats data_doc tycon' typats - ; (derivs', fvs2) <- rn_derivs derivs - ; let fvs = fvs1 `plusFV` fvs2 `plusFV` - extractHsCtxtTyNames context' - `plusFV` maybe emptyFVs extractHsTyNames sig' - ; return ((tyvars', context', typats', derivs'), fvs) } - - -- For the constructor declarations, bring into scope the tyvars - -- bound by the header, but *only* in the H98 case - -- Reason: for GADTs, the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' - | otherwise = [] - ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ + ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig + ; (context', fvs1) <- rnContext data_doc context + ; (typats', fvs2) <- rnTyPats data_doc tycon' typats + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by RnNames.extendGlobalRdrEnvRn - - ; return (TyData {tcdND = new_or_data, tcdCtxt = context', - tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = typats', tcdKindSig = sig', - tcdCons = condecls', tcdDerivs = derivs'}, - con_fvs `plusFV` stuff_fvs) + -- No need to check for duplicate constructor decls + -- since that is done by RnNames.extendGlobalRdrEnvRn + + ; return ( TyData { tcdND = new_or_data, tcdCType = cType + , tcdCtxt = context' + , tcdLName = tycon', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdKindSig = sig' + , tcdCons = condecls', tcdDerivs = derivs'} + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs ) } where h98_style = case condecls of -- Note [Stupid theta] @@ -845,20 +851,23 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, data_doc = TyDataCtx tycon rn_derivs Nothing = return (Nothing, emptyFVs) - rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds - ; return (Just ds', extractHsTyNames_s ds') } + rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds + ; return (Just ds', fvs) } -- "type" and "type instance" declarations -rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name, - tcdTyPats = typats, tcdSynRhs = ty}) - = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do - { -- Checks for distinct tyvars - name' <- lookupTcdName mb_cls tydecl - ; (typats',fvs1) <- rnTyPats syn_doc name' typats - ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty - ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' - , tcdTyPats = typats', tcdSynRhs = ty'} - , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) } +rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars + , tcdLName = name + , tcdTyPats = typats, tcdSynRhs = ty}) + = do { name' <- lookupTcdName (fmap fst mb_cls) tydecl + ; ((tyvars', typats', ty'), fvs) + <- bindTyClTyVars syn_doc mb_cls tyvars $ \ tyvars' -> do + do { (typats',fvs1) <- rnTyPats syn_doc name' typats + ; (ty', fvs2) <- rnLHsType syn_doc ty + ; return ((tyvars', typats', ty'), fvs1 `plusFV` fvs2) } + ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdSynRhs = ty' + , tcdFVs = fvs } + , fvs) } where syn_doc = TySynCtx name @@ -871,19 +880,19 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Tyvars scope over superclass context and method signatures ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) - <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do + <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do -- Checks for distinct tyvars - { context' <- rnContext cls_doc context + { (context', cxt_fvs) <- rnContext cls_doc context ; fds' <- rnFds (docOfHsDocContext cls_doc) fds - ; let rn_at = rnTyClDecl (Just cls') - ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats - ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs - ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs - ; let fvs = extractHsCtxtTyNames context' `plusFV` - hsSigsFVs sigs' `plusFV` - plusFVs fv_ats `plusFV` - plusFVs fv_at_defs -- The fundeps have no free variables + ; let tv_ns = hsLTyVarNames tyvars' + ; (ats', fv_ats) <- rnATDecls cls' tv_ns ats + ; (at_defs', fv_at_defs) <- rnATDecls cls' tv_ns at_defs + ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs + ; let fvs = cxt_fvs `plusFV` + sig_fvs `plusFV` + fv_ats `plusFV` + fv_at_defs ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } -- No need to check for duplicate associated type decls @@ -920,64 +929,11 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', tcdDocs = docs'}, - extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) } + meth_fvs `plusFV` stuff_fvs) } where cls_doc = ClassDeclCtx lcls -bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindQTvs doc mb_cls tyvars thing_inside - | isNothing mb_cls -- Not associated - = bindTyVarsFV doc tyvars thing_inside - | otherwise -- Associated - = do { let tv_rdr_names = map hsLTyVarLocName tyvars - -- *All* the free vars of the family patterns - - -- Check for duplicated bindings - -- This test is irrelevant for data/type *instances*, where the tyvars - -- are the free tyvars of the patterns, and hence have no duplicates - -- But it's needed for data/type *family* decls - ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names) - - ; rdr_env <- getLocalRdrEnv - - ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names - ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns - ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars' - - -- Check that the RHS of the decl mentions only type variables - -- bound on the LHS. For example, this is not ok - -- class C a b where - -- type F a x :: * - -- instance C (p,q) r where - -- type F (p,q) x = (x, r) -- BAD: mentions 'r' - -- c.f. Trac #5515 - ; let bad_tvs = filterNameSet (isTvOcc . nameOccName) fvs - ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs)) - - ; return (thing, fvs) } - where - mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM Name - mk_tv_name rdr_env (L l tv_rdr) - = case lookupLocalRdrEnv rdr_env tv_rdr of - Just n -> return n - Nothing -> newLocalBndrRn (L l tv_rdr) - -badAssocRhs :: [Name] -> RnM () -badAssocRhs ns - = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") - <> plural ns - <+> pprWithCommas (quotes . ppr) ns) - 2 (ptext (sLit "All such variables must be bound on the LHS"))) - -dupBoundTyVar :: [Located RdrName] -> RnM () -dupBoundTyVar (L loc tv : _) - = setSrcSpan loc $ - addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv)) -dupBoundTyVar [] = panic "dupBoundTyVar" - badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), @@ -1045,24 +1001,22 @@ is jolly confusing. See Trac #4875 %********************************************************* \begin{code} -rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) +rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] + -> RnM (Maybe [LHsType Name], FreeVars) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) rnTyPats _ _ Nothing = return (Nothing, emptyFVs) rnTyPats doc tc (Just typats) - = do { typats' <- rnLHsTypes doc typats - ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc) + = do { (typats', fvs) <- rnLHsTypes doc typats + ; return (Just typats', addOneFV fvs (unLoc tc)) } -- type instance => use, hence addOneFV - ; return (Just typats', fvs) } rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) -rnConDecls condecls - = do { condecls' <- mapM (wrapLocM rnConDecl) condecls - ; return (condecls', plusFVs (map conDeclFVs condecls')) } +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) -rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) +rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = res_ty, con_doc = mb_doc @@ -1090,24 +1044,25 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do - { new_context <- rnContext doc cxt - ; new_details <- rnConDeclDetails doc details - ; (new_details', new_res_ty) <- rnConResult doc (unLoc new_name) new_details res_ty + ; bindHsTyVars doc new_tvs $ \new_tyvars -> do + { (new_context, fvs1) <- rnContext doc cxt + ; (new_details, fvs2) <- rnConDeclDetails doc details + ; (new_details', new_res_ty, fvs3) <- 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' }) }} + , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }, + fvs1 `plusFV` fvs2 `plusFV` fvs3) }} where doc = ConDeclCtx name get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys)) rnConResult :: HsDocContext -> Name -> HsConDetails (LHsType Name) [ConDeclField Name] - -> ResType RdrName + -> ResType (LHsType RdrName) -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], - ResType Name) -rnConResult _ _ details ResTyH98 = return (details, ResTyH98) + ResType (LHsType Name), FreeVars) +rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) rnConResult doc con details (ResTyGADT ty) - = do { ty' <- rnLHsType doc ty + = do { (ty', fvs) <- rnLHsType doc ty ; let (arg_tys, res_ty) = splitHsFunType ty' -- We can finally split it up, -- now the renamer has dealt with fixities @@ -1119,7 +1074,7 @@ rnConResult doc con details (ResTyGADT ty) RecCon {} -> do { unless (null arg_tys) (addErr (badRecResTy (docOfHsDocContext doc))) - ; return (details, ResTyGADT res_ty) } + ; return (details, ResTyGADT res_ty, fvs) } PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons] , [ty1,ty2] <- arg_tys @@ -1127,27 +1082,27 @@ rnConResult doc con details (ResTyGADT ty) ; return (if con `elemNameEnv` fix_env then InfixCon ty1 ty2 else PrefixCon arg_tys - , ResTyGADT res_ty) } + , ResTyGADT res_ty, fvs) } | otherwise - -> return (PrefixCon arg_tys, ResTyGADT res_ty) } + -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) } rnConDeclDetails :: HsDocContext -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] - -> RnM (HsConDetails (LHsType Name) [ConDeclField Name]) + -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars) rnConDeclDetails doc (PrefixCon tys) - = do { new_tys <- mapM (rnLHsType doc) tys - ; return (PrefixCon new_tys) } + = do { (new_tys, fvs) <- rnLHsTypes doc tys + ; return (PrefixCon new_tys, fvs) } rnConDeclDetails doc (InfixCon ty1 ty2) - = do { new_ty1 <- rnLHsType doc ty1 - ; new_ty2 <- rnLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2) } + = do { (new_ty1, fvs1) <- rnLHsType doc ty1 + ; (new_ty2, fvs2) <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclDetails doc (RecCon fields) - = do { new_fields <- rnConDeclFields doc fields + = do { (new_fields, fvs) <- rnConDeclFields doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn - ; return (RecCon new_fields) } + ; return (RecCon new_fields, fvs) } ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 5275957ce0..734eee3dad 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -15,7 +15,7 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, - rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields, + rnHsSigType, rnLHsInstType, rnConDeclFields, rnIPName, -- Precence related stuff @@ -26,7 +26,7 @@ module RnTypes ( rnSplice, checkTH, -- Binding related stuff - bindTyVarsRn, bindTyVarsFV + bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig ) where import {-# SOURCE #-} RnExpr( rnLExpr ) @@ -36,8 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) import DynFlags import HsSyn -import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn ( extractHsTyNames, extractHsTyVarBndrNames_s ) +import RdrHsSyn ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars ) import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad @@ -54,7 +53,7 @@ import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi Fixity(..), FixityDirection(..) ) import Outputable import FastString -import Control.Monad ( unless, zipWithM ) +import Control.Monad ( unless ) #include "HsVersions.h" \end{code} @@ -69,23 +68,17 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnHsTypeFVs doc_str ty = do - ty' <- rnLHsType doc_str ty - return (ty', extractHsTyNames ty') - -rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. -rnHsSigType doc_str ty - = rnLHsType (TypeSigCtx doc_str) ty +rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty -rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl rnLHsInstType doc_str ty - = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty + = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) - ; return ty' } + ; return (ty', fvs) } where good_inst_ty | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty @@ -101,27 +94,34 @@ want a gratuitous knot. \begin{code} rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind - -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name) -rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc) + -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsTyKi isType doc (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi isType doc ty + ; return (L loc ty', fvs) } -rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name) +rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsType = rnLHsTyKi True -rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name) + +rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) rnLHsKind = rnLHsTyKi False -rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name)) -rnLHsMaybeKind _ Nothing = return Nothing -rnLHsMaybeKind doc (Just k) = do - k' <- rnLHsKind doc k - return (Just k') -rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name) +rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) + -> RnM (Maybe (LHsKind Name), FreeVars) +rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs) +rnLHsMaybeKind doc (Just k) + = do { (k', fvs) <- rnLHsKind doc k + ; return (Just k', fvs) } + +rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) rnHsType = rnHsTyKi True -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name) +rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) rnHsKind = rnHsTyKi False -rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name) +rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do +rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) + = ASSERT ( isType ) do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} @@ -146,14 +146,11 @@ rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned - ; -- rnForAll does the rest - rnForAll doc Explicit forall_tyvars ctxt tau } + ; rnForAll doc Explicit forall_tyvars ctxt tau } -rnHsTyKi isType _ (HsTyVar rdr_name) = do - -- We use lookupOccRn in kinds because all the names are in - -- TcClsName, and we don't want to look in DataName. - name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name - return (HsTyVar name) +rnHsTyKi isType _ (HsTyVar rdr_name) + = do { name <- rnTyVar isType rdr_name + ; return (HsTyVar name, unitFV name) } -- If we see (forall a . ty), without foralls on, the forall will give -- a sensible error message, but we don't want to complain about the dot too @@ -162,126 +159,152 @@ rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) = ASSERT ( isType ) setSrcSpan loc $ do { ops_ok <- xoptM Opt_TypeOperators ; op' <- if ops_ok - then lookupPromotedOccRn op + then rnTyVar isType op else do { addErr (opTyErr op ty) ; return (mkUnboundName op) } -- Avoid double complaint ; let l_op' = L loc op' ; fix <- lookupTyFixityRn l_op' - ; ty1' <- rnLHsType doc ty1 - ; ty2' <- rnLHsType doc ty2 - ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' } + ; (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) + op' fix ty1' ty2' + ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } -rnHsTyKi isType doc (HsParTy ty) = do - ty' <- rnLHsTyKi isType doc ty - return (HsParTy ty') +rnHsTyKi isType doc (HsParTy ty) + = do { (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsParTy ty', fvs) } rnHsTyKi isType doc (HsBangTy b ty) - = ASSERT ( isType ) do { ty' <- rnLHsType doc ty - ; return (HsBangTy b ty') } + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsBangTy b ty', fvs) } rnHsTyKi isType doc (HsRecTy flds) - = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds - ; return (HsRecTy flds') } + = ASSERT ( isType ) + do { (flds', fvs) <- rnConDeclFields doc flds + ; return (HsRecTy flds', fvs) } -rnHsTyKi isType doc (HsFunTy ty1 ty2) = do - ty1' <- rnLHsTyKi isType doc ty1 +rnHsTyKi isType doc (HsFunTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 -- Might find a for-all as the arg of a function type - ty2' <- rnLHsTyKi isType doc ty2 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - if isType - then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - else return (HsFunTy ty1' ty2') + ; res_ty <- if isType + then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' + else return (HsFunTy ty1' ty2') + ; return (res_ty, fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc listTy@(HsListTy ty) = do - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr listTy)) - ty' <- rnLHsTyKi isType doc ty - return (HsListTy ty') +rnHsTyKi isType doc listTy@(HsListTy ty) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr listTy)) + ; (ty', fvs) <- rnLHsTyKi isType doc ty + ; return (HsListTy ty', fvs) } rnHsTyKi isType doc (HsKindSig ty k) - = ASSERT ( isType ) do { - ; kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless kind_sigs_ok (addErr (kindSigErr ty)) - ; ty' <- rnLHsType doc ty - ; k' <- rnLHsKind doc k - ; return (HsKindSig ty' k') } + = ASSERT ( isType ) + do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (badSigErr False doc ty) + ; (ty', fvs1) <- rnLHsType doc ty + ; (k', fvs2) <- rnLHsKind doc k + ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do - ty' <- rnLHsType doc ty - return (HsPArrTy ty') +rnHsTyKi isType doc (HsPArrTy ty) + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; return (HsPArrTy ty', fvs) } -- 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 - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) - tys' <- mapM (rnLHsTyKi isType doc) tys - return (HsTupleTy tup_con tys') +rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys + ; return (HsTupleTy tup_con tys', fvs) } -- 1. Perhaps we should use a separate extension here? -- 2. Check that the integer is positive? -rnHsTyKi isType _ tyLit@(HsTyLit t) = do - data_kinds <- xoptM Opt_DataKinds - unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) - return (HsTyLit t) - -rnHsTyKi isType doc (HsAppTy ty1 ty2) = do - ty1' <- rnLHsTyKi isType doc ty1 - ty2' <- rnLHsTyKi isType doc ty2 - return (HsAppTy ty1' ty2') - -rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do - ty' <- rnLHsType doc ty - n' <- rnIPName n - return (HsIParamTy n' ty') - -rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do - ty1' <- rnLHsType doc ty1 - ty2' <- rnLHsType doc ty2 - return (HsEqTy ty1' ty2') +rnHsTyKi isType _ tyLit@(HsTyLit t) + = do { data_kinds <- xoptM Opt_DataKinds + ; unless (data_kinds || isType) (addErr (dataKindsErr tyLit)) + ; return (HsTyLit t, emptyFVs) } + +rnHsTyKi isType doc (HsAppTy ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 + ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi isType doc (HsIParamTy n ty) + = ASSERT( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; n' <- rnIPName n + ; return (HsIParamTy n' ty', fvs) } + +rnHsTyKi isType doc (HsEqTy ty1 ty2) + = ASSERT( isType ) + do { (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi isType _ (HsSpliceTy sp _ k) - = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs - ; return (HsSpliceTy sp' fvs k) } + = ASSERT ( isType ) + do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + ; return (HsSpliceTy sp' fvs k, fvs) } -rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do - ty' <- rnLHsType doc ty - haddock_doc' <- rnLHsDoc haddock_doc - return (HsDocTy ty' haddock_doc') +rnHsTyKi isType doc (HsDocTy ty haddock_doc) + = ASSERT ( isType ) + do { (ty', fvs) <- rnLHsType doc ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy ty' haddock_doc', fvs) } #ifndef GHCI rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) #else -rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq - ; rnHsType doc (unLoc ty) } +rnHsTyKi isType doc (HsQuasiQuoteTy qq) + = ASSERT ( isType ) + do { ty <- runQuasiQuoteType qq + ; rnHsType doc (unLoc ty) } #endif -rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty) -rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" -rnHsTyKi isType doc (HsExplicitListTy k tys) = - ASSERT( isType ) - do tys' <- mapM (rnLHsType doc) tys - return (HsExplicitListTy k tys') +rnHsTyKi isType _ (HsCoreTy ty) + = ASSERT ( isType ) + return (HsCoreTy ty, emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi _ _ (HsWrapTy {}) + = panic "rnHsTyKi" + +rnHsTyKi isType doc (HsExplicitListTy k tys) + = ASSERT( isType ) + do { (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitListTy k tys', fvs) } + +rnHsTyKi isType doc (HsExplicitTupleTy kis tys) + = ASSERT( isType ) + do { (tys', fvs) <- rnLHsTypes doc tys + ; return (HsExplicitTupleTy kis tys', fvs) } -rnHsTyKi isType doc (HsExplicitTupleTy kis tys) = - ASSERT( isType ) - do tys' <- mapM (rnLHsType doc) tys - return (HsExplicitTupleTy kis tys') +-------------- +rnTyVar :: Bool -> RdrName -> RnM Name +rnTyVar is_type rdr_name + | is_type = lookupTypeOccRn rdr_name + | otherwise = lookupKindOccRn rdr_name -------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] - -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name] -rnLHsTypes doc tys = mapM (rnLHsType doc) tys + -> RnM ([LHsType Name], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \end{code} \begin{code} rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName] - -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) + -> LHsContext RdrName -> LHsType RdrName + -> RnM (HsType Name, FreeVars) rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- One reason for this case is that a type like Int# @@ -293,48 +316,190 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do - new_ctxt <- rnContext doc ctxt - new_ty <- rnLHsType doc ty - return (HsForAllTy exp new_tyvars new_ctxt new_ty) + = bindHsTyVars doc forall_tyvars $ \ new_tyvars -> + do { (new_ctxt, fvs1) <- rnContext doc ctxt + ; (new_ty, fvs2) <- rnLHsType doc ty + ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly -bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName] +--------------- +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +--------------- +bindTyClTyVars + :: HsDocContext + -> Maybe (Name, [Name]) -- Parent class and its tyvars + -- (but not kind vars) + -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for tyvar binders in type/class declarations +-- Just like bindHsTyVars, but deals with the case of associated +-- types, where the type variables may be already in scope +bindTyClTyVars doc mb_cls tyvars thing_inside + | Just (_, cls_tvs) <- mb_cls -- Associated type family or type instance + = do { let tv_rdr_names = map hsLTyVarLocName tyvars + -- *All* the free vars of the family patterns + + -- Check for duplicated bindings + -- This test is irrelevant for data/type *instances*, where the tyvars + -- are the free tyvars of the patterns, and hence have no duplicates + -- But it's needed for data/type *family* decls + ; checkDupRdrNames tv_rdr_names + + -- Make the Names for the tyvars + ; rdr_env <- getLocalRdrEnv + ; let mk_tv_name :: Located RdrName -> RnM Name + -- Use the same Name as the parent class decl + mk_tv_name (L l tv_rdr) + = case lookupLocalRdrEnv rdr_env tv_rdr of + Just n -> return n + Nothing -> newLocalBndrRn (L l tv_rdr) + ; tv_ns <- mapM mk_tv_name tv_rdr_names + + ; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside + + -- See Note [Renaming associated types] + ; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs + ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs)) + + ; return (thing, fvs) } + + | otherwise -- Not associated, just fall through to bindHsTyVars + = bindHsTyVars doc tyvars thing_inside + +badAssocRhs :: [Name] -> RnM () +badAssocRhs ns + = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") + <> plural ns + <+> pprWithCommas (quotes . ppr) ns) + 2 (ptext (sLit "All such variables must be bound on the LHS"))) + +--------------- +bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -bindTyVarsFV doc tyvars thing_inside - = bindTyVarsRn doc tyvars $ \ tyvars' -> - do { (res, fvs) <- thing_inside tyvars' - ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) } - -bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM a) - -> RnM a --- Haskell-98 binding of type variables; e.g. within a data type decl -bindTyVarsRn doc tyvar_names enclosed_scope - = bindLocatedLocalsRn located_tyvars $ \ names -> - do { kind_sigs_ok <- xoptM Opt_KindSignatures - ; unless (null kinded_tyvars || kind_sigs_ok) - (mapM_ (addErr . kindSigErr) kinded_tyvars) - ; tyvar_names' <- zipWithM replace tyvar_names names - ; enclosed_scope tyvar_names' } +bindHsTyVars doc tv_bndrs thing_inside + = do { checkDupAndShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindTyVarsRn doc tv_bndrs names thing_inside } where - replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc - located_tyvars = hsLTyVarLocNames tyvar_names - kinded_tyvars = [n | L _ (KindedTyVar n _ _) <- tyvar_names] + rdr_names_w_loc = hsLTyVarLocNames tv_bndrs -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name] -rnConDeclFields doc fields = mapM (rnField doc) fields - -rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name) -rnField doc (ConDeclField name ty haddock_doc) - = do { new_name <- lookupLocatedTopBndrRn name - ; new_ty <- rnLHsType doc ty - ; new_haddock_doc <- rnMbLHsDoc haddock_doc - ; return (ConDeclField new_name new_ty new_haddock_doc) } +--------------- +bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name] + -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Rename the HsTyVarBndrs, giving them the specified names +-- *and* bringing into scope the kind variables bound in +-- any kind signatures + +bindTyVarsRn doc tv_bndrs names thing_inside + = go tv_bndrs names $ \ tv_bndrs' -> + bindLocalNamesFV names (thing_inside tv_bndrs') + where + go [] [] thing_inside = thing_inside [] + + go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside + = go tvs ns $ \ tvs' -> + thing_inside (L loc (UserTyVar n tck) : tvs') + + go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside + = rnHsBndrSig False doc bsig $ \ bsig' -> + go tvs ns $ \ tvs' -> + thing_inside (L loc (KindedTyVar n bsig' tck) : tvs') + + -- Lists of unequal length + go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names) + +-------------------------------- +rnHsBndrSig :: Bool -- True <=> type sig, False <=> kind sig + -> HsDocContext + -> HsBndrSig (LHsType RdrName) + -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsBndrSig is_type doc (HsBSig ty _) thing_inside + = do { name_env <- getLocalRdrEnv + ; let tv_bndrs = [ tv | tv <- extractHsTyRdrTyVars ty + , not (unLoc tv `elemLocalRdrEnv` name_env) ] + + ; checkHsBndrFlags is_type doc ty tv_bndrs + ; bindLocatedLocalsFV tv_bndrs $ \ tv_names -> do + { (ty', fvs1) <- rnLHsTyKi is_type doc ty + ; (res, fvs2) <- thing_inside (HsBSig ty' tv_names) + ; return (res, fvs1 `plusFV` fvs2) } } + +checkHsBndrFlags :: Bool -> HsDocContext + -> LHsType RdrName -> [Located RdrName] -> RnM () +checkHsBndrFlags is_type doc ty tv_bndrs + | is_type -- Type + = do { sig_ok <- xoptM Opt_ScopedTypeVariables + ; unless sig_ok (badSigErr True doc ty) } + | otherwise -- Kind + = do { sig_ok <- xoptM Opt_KindSignatures + ; unless sig_ok (badSigErr False doc ty) + ; poly_kind <- xoptM Opt_PolyKinds + ; unless (poly_kind || null tv_bndrs) + (addErr (badKindBndrs doc ty tv_bndrs)) } + +badKindBndrs :: HsDocContext -> LHsKind RdrName -> [Located RdrName] -> SDoc +badKindBndrs doc _kind kvs + = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs + <+> pprQuotedList kvs) + 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds")) + , docOfHsDocContext doc ] + +badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () +badSigErr is_type doc (L loc ty) + = setSrcSpan loc $ addErr $ + vcat [ hang (ptext (sLit "Illegal") <+> what + <+> ptext (sLit "signature:") <+> quotes (ppr ty)) + 2 (ptext (sLit "Perhaps you intended to use") <+> flag) + , docOfHsDocContext doc ] + where + what | is_type = ptext (sLit "type") + | otherwise = ptext (sLit "kind") + flag | is_type = ptext (sLit "-XScopedTypeVariable") + | otherwise = ptext (sLit "-XKindSignatures") \end{code} +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. Trac #5515 + +What makes it tricky is that the *kind* variable from the class *are* +in scope (Trac #5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature even though it's not +explicitly mentioned on the LHS of the type Ob declaration. + +We could force you to mention k explicitly, thus + class Category (x :: k -> k -> *) where + type Ob (x :: k -> k -> *) :: k -> Constraint +but it seems tiresome to do so. + + %********************************************************* %* * \subsection{Contexts and predicates} @@ -342,11 +507,21 @@ rnField doc (ConDeclField name ty haddock_doc) %********************************************************* \begin{code} -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name) -rnContext doc = wrapLocM (rnContext' doc) +rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] + -> RnM ([ConDeclField Name], FreeVars) +rnConDeclFields doc fields = mapFvRn (rnField doc) fields + +rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars) +rnField doc (ConDeclField name ty haddock_doc) + = do { new_name <- lookupLocatedTopBndrRn name + ; (new_ty, fvs) <- rnLHsType doc ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } -rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mapM (rnLHsType doc) ctxt +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext doc (L loc cxt) + = do { (cxt', fvs) <- rnLHsTypes doc cxt + ; return (L loc cxt', fvs) } rnIPName :: IPName RdrName -> RnM (IPName Name) rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n))) diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 829c2ca40f..4af626d053 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -137,7 +137,7 @@ showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () endPass dflags pass binds rules - = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules + = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules ; lintPassResult dflags pass binds } where mb_flag = case coreDumpFlag pass of @@ -167,9 +167,9 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules -- This has the side effect of forcing the intermediate to be evaluated where - dump_doc = vcat [ text "Result size =" <+> int (coreBindsSize binds) - , extra_info - , blankLine + dump_doc = vcat [ nest 2 extra_info + , nest 2 (text "Result size =" <+> int (coreBindsSize binds)) + , blankLine , pprCoreBindings binds , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine @@ -307,7 +307,8 @@ instance Outputable CoreToDo where ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n +pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n + , ppr md ] pprPassDetails _ = empty \end{code} diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index beb64cb061..394cd9801e 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -68,7 +68,9 @@ import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it import Coercion ( isCoVar ) import CoreSubst ( Subst, emptySubst, extendInScope, substBndr, substRecBndrs, - extendIdSubst, extendSubstWithVar, cloneBndr, cloneRecIdBndrs, substTy, substCo ) + extendIdSubst, extendSubstWithVar, cloneBndr, + cloneRecIdBndrs, substTy, substCo ) +import MkCore ( sortQuantVars ) import Id import IdInfo import Var @@ -78,8 +80,7 @@ import Literal ( litIsTrivial ) import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( isUnLiftedType, Type, sortQuantVars, mkPiTypes ) -import Kind ( kiVarsOfKinds ) +import Type ( isUnLiftedType, Type, mkPiTypes ) import BasicTypes ( Arity ) import UniqSupply import Util @@ -419,7 +420,10 @@ the inner loop. Things to note * We can't float a case to top level * It's worth doing this float even if we don't float - the case outside a value lambda + the case outside a value lambda. Example + case x of { + MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...) + If we floated the cases out we could eliminate one of them. * We only do this with a single-alternative case Note [Check the output scrutinee for okForSpec] @@ -997,9 +1001,9 @@ abstractVars :: Level -> LevelEnv -> VarSet -> [Var] -- whose level is greater than the destination level -- These are the ones we are going to abstract out abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs - = map zap $ uniq $ sortQuantVars -- IA0_NOTE: centralizing sorting on variables + = map zap $ uniq $ sortQuantVars [var | fv <- varSetElems fvs - , var <- absVarsOf id_env fv + , var <- varSetElems (absVarsOf id_env fv) , abstract_me var ] -- NB: it's important to call abstract_me only on the OutIds the -- come from absVarsOf (not on fv, which is an InId) @@ -1022,7 +1026,7 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs setIdInfo v vanillaIdInfo | otherwise = v -absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] +absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> VarSet -- If f is free in the expression, and f maps to poly_f a b c in the -- current substitution, then we must report a b c as candidate type -- variables @@ -1030,20 +1034,16 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] -- Also, if x::a is an abstracted variable, then so is a; that is, -- we must look in x's type. What's more, if a mentions kind variables, -- we must also return those. - -- - -- And similarly if x is a coercion variable. absVarsOf id_env v - | isId v = [av2 | av1 <- lookup_avs v - , av2 <- add_tyvars av1] - | otherwise = ASSERT( isTyVar v ) [v] + | isId v, Just (abs_vars, _) <- lookupVarEnv id_env v + = foldr (unionVarSet . close) emptyVarSet abs_vars + | otherwise + = close v where - lookup_avs v = case lookupVarEnv id_env v of - Just (abs_vars, _) -> abs_vars - Nothing -> [v] - - add_tyvars v = v : (varSetElems tyvars ++ varSetElems kivars) - tyvars = varTypeTyVars v - kivars = kiVarsOfKinds (map tyVarKind (varSetElems tyvars)) + close :: Var -> VarSet -- Result include the input variable itself + close v = foldVarSet (unionVarSet . close) + (unitVarSet v) + (varTypeTyVars v) \end{code} \begin{code} diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index ad6fe5488b..7da185a1ae 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -38,6 +38,7 @@ module SimplUtils ( import SimplEnv import CoreMonad ( SimplifierMode(..), Tick(..) ) +import MkCore ( sortQuantVars ) import DynFlags import StaticFlags import CoreSyn diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 900d70c7de..b8c8160972 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1416,7 +1416,7 @@ completeCall env var cont pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1668,6 +1668,22 @@ not want to transform to in blah because that builds an unnecessary thunk. +Note [Case elimination: unlifted case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case a +# b of r -> ...r... +Then we do case-elimination (to make a let) followed by inlining, +to get + .....(a +# b).... +If we have + case indexArray# a i of r -> ...r... +we might like to do the same, and inline the (indexArray# a i). +But indexArray# is not okForSpeculation, so we don't build a let +in rebuildCase (lest it get floated *out*), so the inlining doesn't +happen either. + +This really isn't a big deal I think. The let can be + Further notes about case elimination ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1788,6 +1804,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont | 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 + -- See Note [Case elimination: unlifted case] ok_for_spec = exprOkForSpeculation scrut is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index a452593a3e..321deb866a 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -1071,12 +1071,15 @@ specCalls subst rules_for_me calls_for_me fn rhs (substInScope subst) fn args rules_for_me) - mk_ty_args :: [Maybe Type] -> [CoreExpr] - mk_ty_args call_ts = zipWithEqual "spec_call" mk_ty_arg rhs_tyvars call_ts - where - mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar) - mk_ty_arg _ (Just ty) = Type ty - + mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] + mk_ty_args [] poly_tvs + = ASSERT( null poly_tvs ) [] + mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs) + = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs + mk_ty_args (Just ty : call_ts) poly_tvs + = Type ty : mk_ty_args call_ts poly_tvs + mk_ty_args (Nothing : _) [] = panic "mk_ty_args" + ---------------------------------------------------------- -- Specialise to one particular call pattern spec_call :: CallInfo -- Call instance @@ -1103,17 +1106,19 @@ specCalls subst rules_for_me calls_for_me fn rhs -- poly_tyvars = [b] in the example above -- spec_tyvars = [a,c] -- ty_args = [t1,b,t3] - poly_tyvars = [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts] spec_ty_args = map snd spec_tv_binds - ty_args = mk_ty_args call_ts - rhs_subst = CoreSubst.extendTvSubstList subst spec_tv_binds + subst1 = CoreSubst.extendTvSubstList subst spec_tv_binds + (rhs_subst, poly_tyvars) + = CoreSubst.substBndrs subst1 + [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts] ; (rhs_subst1, inst_dict_ids) <- newDictBndrs rhs_subst rhs_dict_ids -- Clone rhs_dicts, including instantiating their types ; let (rhs_subst2, dx_binds) = bindAuxiliaryDicts rhs_subst1 $ (my_zipEqual rhs_dict_ids inst_dict_ids call_ds) + ty_args = mk_ty_args call_ts poly_tyvars inst_args = ty_args ++ map Var inst_dict_ids ; if already_covered inst_args then @@ -1132,7 +1137,7 @@ specCalls subst rules_for_me calls_for_me fn rhs ; let -- The rule to put in the function's specialisation is: -- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b - rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args)) + rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args)) spec_env_rule = mkRule True {- Auto generated -} is_local rule_name inl_act -- Note [Auto-specialisation and RULES] diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 98e5303b02..71bdfe97c9 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -545,7 +545,7 @@ coreToStgApp _ f args = do StgOpApp (StgPrimOp op) args' res_ty -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _)) + FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _)) -> ASSERT( saturated ) StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index be0205f323..ec09c4d9a7 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -391,8 +391,8 @@ checkFunApp fun_ty arg_tys msg where (mb_ty, mb_msg) = cfa True fun_ty arg_tys - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe MsgDoc) -- Errors? + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -439,12 +439,12 @@ stgEqType orig_ty1 orig_ty2 | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 , let res = if tc1 == tc2 - then equalLength tc_args1 tc_args2 - && and (zipWith go tc_args1 tc_args2) - else -- TyCons don't match; but don't bleat if either is a - -- family TyCon because a coercion might have made it - -- equal to something else - (isFamilyTyCon tc1 || isFamilyTyCon tc2) + then equalLength tc_args1 tc_args2 + && and (zipWith go tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) = if res then True else pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index c873c631da..1e24a530aa 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -27,8 +27,8 @@ import Module import SrcLoc import Outputable import UniqFM +import VarSet import FastString -import VarSet ( varSetElems ) import Util( filterOut ) import Maybes import Control.Monad @@ -174,11 +174,12 @@ tcLookupFamInst tycon tys = return Nothing | otherwise = do { instEnv <- tcGetFamInstEnvs - ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv) - ; case lookupFamInstEnv instEnv tycon tys of - [] -> return Nothing + ; let mb_match = lookupFamInstEnv instEnv tycon tys + ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ ppr mb_match $$ ppr instEnv) + ; case mb_match of + [] -> return Nothing ((fam_inst, rep_tys):_) - -> return $ Just (fam_inst, rep_tys) + -> return $ Just (fam_inst, rep_tys) } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) @@ -263,18 +264,15 @@ addLocalFamInst (home_fie, my_fis) fam_inst -- 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) } - } + ; no_conflict <- checkForConflicts inst_envs fam_inst + ; if no_conflict then + return (home_fie'', fam_inst : my_fis') + else + return (home_fie, my_fis) } \end{code} %************************************************************************ @@ -287,8 +285,8 @@ Check whether a single family instance conflicts with those in two instance environments (one for the EPS and one for the HPT). \begin{code} -checkForConflicts :: FamInstEnvs -> FamInst -> TcM () -checkForConflicts inst_envs famInst +checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForConflicts inst_envs fam_inst = do { -- To instantiate the family instance type, extend the instance -- envt with completely fresh template variables -- This is important because the template variables must @@ -297,11 +295,13 @@ checkForConflicts inst_envs famInst -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - ; skol_tvs <- tcInstSkolTyVars (varSetElems (famInstTyVars famInst)) - ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs - ; unless (null conflicts) $ - conflictInstErr famInst (fst (head conflicts)) - } + ; (_, skol_tvs) <- tcInstSkolTyVars (coAxiomTyVars (famInstAxiom fam_inst)) + ; let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst skol_tvs + no_conflicts = null conflicts + ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) + ; unless no_conflicts $ + conflictInstErr fam_inst (fst (head conflicts)) + ; return no_conflicts } conflictInstErr :: FamInst -> FamInst -> TcRn () conflictInstErr famInst conflictingFamInst diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a194d748ed..0833a7c7cf 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -152,8 +152,7 @@ deeplySkolemise deeplySkolemise ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys - ; tvs1 <- tcInstSkolTyVars tvs - ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1) + ; (subst, tvs1) <- tcInstSkolTyVars tvs ; ev_vars1 <- newEvVars (substTheta subst theta) ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty') ; return ( mkWpLams ids1 @@ -219,7 +218,7 @@ instCallConstraints _ [] = return idHsWrapper instCallConstraints origin (pred : preds) | Just (ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut - = do { traceTc "instCallConstraints" $ ppr (mkEqPred (ty1, ty2)) + = do { traceTc "instCallConstraints" $ ppr (mkEqPred ty1 ty2) ; co <- unifyType ty1 ty2 ; co_fn <- instCallConstraints origin preds ; return (co_fn <.> WpEvApp (EvCoercion co)) } diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 2934cda94b..e15b2adc6e 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -138,7 +138,7 @@ tc_cmd env (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. - ; [r_tv] <- tcInstSkolTyVars [alphaTyVar] + ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) @@ -245,7 +245,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] - ; [w_tv] <- tcInstSkolTyVars [alphaTyVar] + ; (_, [w_tv]) <- tcInstSkolTyVars [alphaTyVar] ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point -- a ((w,t1) .. tn) t diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index e14bd49458..1cc97de8d3 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,9 +6,10 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyBinds, + tcHsBootSigs, tcPolyBinds, tcPolyCheck, PragFun, tcSpecPrags, tcVectDecls, mkPragFun, - TcSigInfo(..), SigFun, mkSigFun, + TcSigInfo(..), TcSigFun, + instTcTySig, instTcTySigFromId, badBootDeclErr ) where import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) @@ -82,6 +83,65 @@ type-checking the LHS of course requires that the binder is in scope. At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is + + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. + +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: + + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. + +NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), +which would make the space leak go away in this case + +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. + +Then we get + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm + \begin{code} tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv) -- The TcGblEnv contains the new tcg_binds and tcg_spects @@ -191,16 +251,9 @@ tcValBinds :: TopLevelFlag tcValBinds top_lvl binds sigs thing_inside = do { -- Typecheck the signature - ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) - ; ty_sigs = filter isTypeLSig sigs - ; sig_fn = mkSigFun ty_sigs } + (poly_ids, sig_fn) <- tcTySigs sigs - ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs) - -- No recovery from bad signatures, because the type sigs - -- may bind type variables, so proceeding without them - -- can lead to a cascade of errors - -- ToDo: this means we fall over immediately if any type sig - -- is wrong, which is over-conservative, see Trac bug #745 + ; let prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds) -- Extend the envt right away with all -- the Ids declared with type signatures @@ -211,7 +264,7 @@ tcValBinds top_lvl binds sigs thing_inside ; return (binds', thing) } ------------------------ -tcBindGroups :: TopLevelFlag -> SigFun -> PragFun +tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun -> [(RecFlag, LHsBinds Name)] -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) -- Typecheck a whole lot of value bindings, @@ -232,7 +285,7 @@ tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside ------------------------ tc_group :: forall thing. - TopLevelFlag -> SigFun -> PragFun + TopLevelFlag -> TcSigFun -> PragFun -> (RecFlag, LHsBinds Name) -> TcM thing -> TcM ([(RecFlag, LHsBinds TcId)], thing) @@ -276,7 +329,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive ------------------------ -mkEdges :: SigFun -> LHsBinds Name +mkEdges :: TcSigFun -> LHsBinds Name -> [(LHsBind Name, BKey, [BKey])] type BKey = Int -- Just number off the bindings @@ -303,7 +356,7 @@ bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" ------------------------ -tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun +tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun -> RecFlag -- Whether the group is really recursive -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures @@ -328,18 +381,18 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list { traceTc "------------------------------------------------" empty ; traceTc "Bindings for" (ppr binder_names) - -- Instantiate the polytypes of any binders that have signatures - -- (as determined by sig_fn), returning a TcSigInfo for each - ; tc_sig_fn <- tcInstSigs sig_fn binder_names +-- -- Instantiate the polytypes of any binders that have signatures +-- -- (as determined by sig_fn), returning a TcSigInfo for each +-- ; tc_sig_fn <- tcInstSigs sig_fn binder_names ; dflags <- getDynFlags ; type_env <- getLclTypeEnv ; let plan = decideGeneralisationPlan dflags type_env - binder_names bind_list tc_sig_fn + binder_names bind_list sig_fn ; traceTc "Generalisation plan" (ppr plan) ; result@(_, poly_ids, _) <- case plan of - NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list - InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list + NoGen -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list + InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list -- Check whether strict bindings are ok @@ -371,7 +424,7 @@ tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list ; return (binds', mono_ids', NotTopLevel) } where tc_mono_info (name, _, mono_id) - = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id) + = do { mono_ty' <- zonkTcType (idType mono_id) -- Zonk, mainly to expose unboxed types to checkStrictBinds ; let mono_id' = setIdType mono_id mono_ty' ; _specs <- tcSpecPrags mono_id' (prag_fn name) @@ -390,16 +443,17 @@ tcPolyCheck :: TcSigInfo -> PragFun -- There is just one binding, -- it binds a single variable, -- it has a signature, -tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped - , sig_theta = theta, sig_tau = tau }) +tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped + , sig_theta = theta, sig_tau = tau, sig_loc = loc }) prag_fn rec_tc bind_list - = do { loc <- getSrcSpanM - ; ev_vars <- newEvVars theta + = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau) prag_sigs = prag_fn (idName poly_id) + ; tvs <- mapM (skolemiseSigTv . snd) tvs_w_scoped ; (ev_binds, (binds', [mono_info])) - <- checkConstraints skol_info tvs ev_vars $ - tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $ + <- setSrcSpan loc $ + checkConstraints skol_info tvs ev_vars $ + tcExtendTyVarEnv2 [(n,tv) | (Just n, tv) <- tvs_w_scoped] $ tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list ; spec_prags <- tcSpecPrags poly_id prag_sigs @@ -471,7 +525,7 @@ mkExport :: PragFun -- Pre-condition: the qtvs and theta are already zonked mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) - = do { mono_ty <- zonkTcTypeCarefully (idType mono_id) + = do { mono_ty <- zonkTcType (idType mono_id) ; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty my_tvs = filter (`elemVarSet` used_tvs) qtvs used_tvs = tyVarsOfTypes theta `unionVarSet` tyVarsOfType mono_ty @@ -747,7 +801,7 @@ scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must b -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id], TopLevelFlag) recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) ; poly_ids <- mapM mk_dummy binder_names @@ -945,161 +999,6 @@ getMonoBindInfo tc_binds \end{code} -%************************************************************************ -%* * - Generalisation -%* * -%************************************************************************ - -unifyCtxts checks that all the signature contexts are the same -The type signatures on a mutually-recursive group of definitions -must all have the same context (or none). - -The trick here is that all the signatures should have the same -context, and we want to share type variables for that context, so that -all the right hand sides agree a common vocabulary for their type -constraints - -We unify them because, with polymorphic recursion, their types -might not otherwise be related. This is a rather subtle issue. - -\begin{code} -{- -unifyCtxts :: [TcSigInfo] -> TcM () --- Post-condition: the returned Insts are full zonked -unifyCtxts [] = return () -unifyCtxts (sig1 : sigs) - = do { traceTc "unifyCtxts" (ppr (sig1 : sigs)) - ; mapM_ unify_ctxt sigs } - where - theta1 = sig_theta sig1 - unify_ctxt :: TcSigInfo -> TcM () - unify_ctxt sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (sig_loc sig) $ - addErrCtxt (sigContextsCtxt sig1 sig) $ - do { mk_cos <- unifyTheta theta1 theta - ; -- Check whether all coercions are identity coercions - -- That can happen if we have, say - -- f :: C [a] => ... - -- g :: C (F a) => ... - -- where F is a type function and (F a ~ [a]) - -- Then unification might succeed with a coercion. But it's much - -- much simpler to require that such signatures have identical contexts - checkTc (isReflMkCos mk_cos) - (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) - } - ------------------------------------------------ -sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc -sigContextsCtxt sig1 sig2 - = vcat [ptext (sLit "When matching the contexts of the signatures for"), - nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), - ppr id2 <+> dcolon <+> ppr (idType id2)]), - ptext (sLit "The signature contexts in a mutually recursive group should all be identical")] - where - id1 = sig_id sig1 - id2 = sig_id sig2 --} -\end{code} - - -@getTyVarsToGen@ decides what type variables to generalise over. - -For a "restricted group" -- see the monomorphism restriction -for a definition -- we bind no dictionaries, and -remove from tyvars_to_gen any constrained type variables - -*Don't* simplify dicts at this point, because we aren't going -to generalise over these dicts. By the time we do simplify them -we may well know more. For example (this actually came up) - f :: Array Int Int - f x = array ... xs where xs = [1,2,3,4,5] -We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) -stuff. If we simplify only at the f-binding (not the xs-binding) -we'll know that the literals are all Ints, and we can just produce -Int literals! - -Find all the type variables involved in overloading, the -"constrained_tyvars". These are the ones we *aren't* going to -generalise. We must be careful about doing this: - - (a) If we fail to generalise a tyvar which is not actually - constrained, then it will never, ever get bound, and lands - up printed out in interface files! Notorious example: - instance Eq a => Eq (Foo a b) where .. - Here, b is not constrained, even though it looks as if it is. - Another, more common, example is when there's a Method inst in - the LIE, whose type might very well involve non-overloaded - type variables. - [NOTE: Jan 2001: I don't understand the problem here so I'm doing - the simple thing instead] - - (b) On the other hand, we mustn't generalise tyvars which are constrained, - because we are going to pass on out the unmodified LIE, with those - tyvars in it. They won't be in scope if we've generalised them. - -So we are careful, and do a complete simplification just to find the -constrained tyvars. We don't use any of the results, except to -find which tyvars are constrained. - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. - -NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...), -which would make the space leak go away in this case - -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - -Then we get - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm %************************************************************************ %* * @@ -1142,7 +1041,6 @@ However, we do *not* support this Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec - Note [More instantiated than scoped] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There may be more instantiated type variables than lexically-scoped @@ -1194,70 +1092,65 @@ For example: it's all cool; each signature has distinct type variables from the renamer.) \begin{code} -type SigFun = Name -> Maybe ([Name], SrcSpan) - -- Maps a let-binder to the list of - -- type variables brought into scope - -- by its type signature, plus location - -- Nothing => no type signature - -mkSigFun :: [LSig Name] -> SigFun --- Search for a particular type signature --- Precondition: the sigs are all type sigs --- Precondition: no duplicates -mkSigFun sigs = lookupNameEnv env +tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = do { ty_sigs <- concat <$> checkNoErrs (mapAndRecoverM tcTySig hs_sigs) + -- No recovery from bad signatures, because the type sigs + -- may bind type variables, so proceeding without them + -- can lead to a cascade of errors + -- ToDo: this means we fall over immediately if any type sig + -- is wrong, which is over-conservative, see Trac bug #745 + ; let env = mkNameEnv [(idName (sig_id sig), sig) | sig <- ty_sigs] + ; return (map sig_id ty_sigs, lookupNameEnv env) } + +tcTySig :: LSig Name -> TcM [TcSigInfo] +tcTySig (L loc (IdSig id)) + = do { sig <- instTcTySigFromId loc id + ; return [sig] } +tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty)) + = setSrcSpan loc $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty + ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) } +tcTySig _ = return [] + +instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo +instTcTySigFromId loc id + = do { (tvs, theta, tau) <- tcInstType inst_sig_tyvars (idType id) + ; return (TcSigInfo { sig_id = id, sig_loc = loc + , sig_tvs = [(Nothing, tv) | tv <- tvs] + , sig_theta = theta, sig_tau = tau }) } where - env = mkNameEnv (concatMap mk_pair sigs) - mk_pair (L loc (IdSig id)) = [(idName id, ([], loc))] - mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames + -- Hack: in an instance decl we use the selector id as + -- the template; but we do *not* want the SrcSpan on the Name of + -- those type variables to refer to the class decl, rather to + -- the instance decl + inst_sig_tyvars tvs = tcInstSigTyVars (map set_loc tvs) + set_loc tv = setTyVarName tv (mkInternalName (nameUnique n) (nameOccName n) loc) where - f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc)) - mk_pair _ = [] - -- The scoped names are the ones explicitly mentioned - -- in the HsForAll. (There may be more in sigma_ty, because - -- of nested type synonyms. See Note [More instantiated than scoped].) - -- See Note [Only scoped tyvars are in the TyVarEnv] -\end{code} + n = tyVarName tv + +instTcTySig :: LHsType Name -> TcType -- HsType and corresponding TcType + -> Name -> TcM TcSigInfo +instTcTySig hs_ty@(L loc _) sigma_ty name + = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty + ; return (TcSigInfo { sig_id = poly_id, sig_loc = loc + , sig_tvs = zipEqual "instTcTySig" scoped_tvs inst_tvs + , sig_theta = theta, sig_tau = tau }) } + where + poly_id = mkLocalId name sigma_ty -\begin{code} -tcTySig :: LSig Name -> TcM [TcId] -tcTySig (L span (TypeSig names@(L _ name1 : _) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) ty - ; return [ mkLocalId name sigma_ty | L _ name <- names ] } -tcTySig (L _ (IdSig id)) - = return [id] -tcTySig s = pprPanic "tcTySig" (ppr s) + scoped_names = hsExplicitTvs hs_ty + (sig_tvs,_) = tcSplitForAllTys sigma_ty -------------------- -tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun -tcInstSigs sig_fn bndrs - = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs - ; return (lookupNameEnv (mkNameEnv prs)) } - where - use_skols = isSingleton bndrs -- See Note [Signature skolems] + scoped_tvs :: [Maybe Name] + scoped_tvs = mk_scoped scoped_names sig_tvs -tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo)) --- For use_skols :: Bool see Note [Signature skolems] --- --- We must instantiate with fresh uniques, --- (see Note [Instantiate sig with fresh variables]) --- although we keep the same print-name. - -tcInstSig sig_fn use_skols name - | Just (scoped_tvs, loc) <- sig_fn name - = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into - -- scope when starting the binding group - ; let poly_ty = idType poly_id - ; (tvs, theta, tau) <- if use_skols - then tcInstType tcInstSkolTyVars poly_ty - else tcInstType tcInstSigTyVars poly_ty - ; let sig = TcSigInfo { sig_id = poly_id - , sig_scoped = scoped_tvs - , sig_tvs = tvs, sig_theta = theta, sig_tau = tau - , sig_loc = loc } - ; return (Just (name, sig)) } - | otherwise - = return Nothing + mk_scoped :: [Name] -> [TyVar] -> [Maybe Name] + mk_scoped [] tvs = [Nothing | _ <- tvs] + mk_scoped (n:ns) (tv:tvs) + | n == tyVarName tv = Just n : mk_scoped ns tvs + | otherwise = Nothing : mk_scoped (n:ns) tvs + mk_scoped (n:ns) [] = pprPanic "mk_scoped" (ppr name $$ ppr (n:ns) $$ ppr hs_ty $$ ppr sigma_ty) ------------------------------- data GeneralisationPlan @@ -1268,7 +1161,8 @@ data GeneralisationPlan Bool -- True <=> bindings mention only variables with closed types -- See Note [Bindings with closed types] in TcRnTypes - | CheckGen TcSigInfo -- Explicit generalisation; there is an AbsBinds + | CheckGen TcSigInfo -- One binding with a signature + -- Explicit generalisation; there is an AbsBinds -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 2e87aa5d77..5dfa05d60a 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -26,6 +26,7 @@ import TypeRep import Name ( Name ) import Var import VarEnv +import Util( equalLength ) import Outputable import Control.Monad ( when, unless, zipWithM ) import MonadUtils @@ -37,7 +38,7 @@ import TcSMonad import FastString import Data.Maybe ( isNothing ) - +import Data.List ( zip4 ) \end{code} @@ -111,16 +112,19 @@ andWhenContinue tcs1 tcs2 Note [Caching for canonicals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our plan with pre-canonicalization is to be able to solve a constraint really fast from existing -bindings in TcEvBinds. So one may think that the condition (isCNonCanonical) is not necessary. -However consider the following setup: +Our plan with pre-canonicalization is to be able to solve a constraint +really fast from existing bindings in TcEvBinds. So one may think that +the condition (isCNonCanonical) is not necessary. However consider +the following setup: InertSet = { [W] d1 : Num t } WorkList = { [W] d2 : Num t, [W] c : t ~ Int} -Now, we prioritize equalities, but in our concrete example (should_run/mc17.hs) the first (d2) constraint -is dealt with first, because (t ~ Int) is an equality that only later appears in the worklist since it is -pulled out from a nested implication constraint. So, let's examine what happens: +Now, we prioritize equalities, but in our concrete example +(should_run/mc17.hs) the first (d2) constraint is dealt with first, +because (t ~ Int) is an equality that only later appears in the +worklist since it is pulled out from a nested implication +constraint. So, let's examine what happens: - We encounter work item (d2 : Num t) @@ -129,27 +133,33 @@ pulled out from a nested implication constraint. So, let's examine what happens: d2 := d1 and we discard d2 from the worklist. The inert set remains unaffected. - - Now the equation ([W] c : t ~ Int) is encountered and kicks-out (d1 : Num t) from the inerts. - Then that equation gets spontaneously solved, perhaps. We end up with: + - Now the equation ([W] c : t ~ Int) is encountered and kicks-out + (d1 : Num t) from the inerts. Then that equation gets + spontaneously solved, perhaps. We end up with: InertSet : { [G] c : t ~ Int } WorkList : { [W] d1 : Num t} - - Now we examine (d1), we observe that there is a binding for (Num t) in the evidence binds and - we set: + - Now we examine (d1), we observe that there is a binding for (Num + t) in the evidence binds and we set: d1 := d2 and end up in a loop! -Now, the constraints that get kicked out from the inert set are always Canonical, so by restricting -the use of the pre-canonicalizer to NonCanonical constraints we eliminate this danger. Moreover, for -canonical constraints we already have good caching mechanisms (effectively the interaction solver) -and we are interested in reducing things like superclasses of the same non-canonical constraint being -generated hence I don't expect us to lose a lot by introducing the (isCNonCanonical) restriction. +Now, the constraints that get kicked out from the inert set are always +Canonical, so by restricting the use of the pre-canonicalizer to +NonCanonical constraints we eliminate this danger. Moreover, for +canonical constraints we already have good caching mechanisms +(effectively the interaction solver) and we are interested in reducing +things like superclasses of the same non-canonical constraint being +generated hence I don't expect us to lose a lot by introducing the +(isCNonCanonical) restriction. -A similar situation can arise in TcSimplify, at the end of the solve_wanteds function, where constraints -from the inert set are returned as new work -- our substCt ensures however that if they are not rewritten -by subst, they remain canonical and hence we will not attempt to solve them from the EvBinds. If on the -other hand they did get rewritten and are now non-canonical they will still not match the EvBinds, so we -are again good. +A similar situation can arise in TcSimplify, at the end of the +solve_wanteds function, where constraints from the inert set are +returned as new work -- our substCt ensures however that if they are +not rewritten by subst, they remain canonical and hence we will not +attempt to solve them from the EvBinds. If on the other hand they did +get rewritten and are now non-canonical they will still not match the +EvBinds, so we are again good. @@ -201,75 +211,21 @@ canEvVar :: EvVar -> PredTree -- 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 - `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 - where emit_superclasses ct@(CDictCan {cc_id = v_new - , cc_tyargs = xis_new, cc_class = cls }) - -- Add superclasses of this one here, See Note [Adding superclasses]. - -- But only if we are not simplifying the LHS of a rule. - = 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 --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ClassPred cls tys -> canClassNC d fl ev cls tys + EqPred ty1 ty2 -> canEqNC d fl ev ty1 ty2 + 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 +\end{code} + + +%************************************************************************ +%* * +%* Tuple Canonicalization +%* * +%************************************************************************ + +\begin{code} canTuple :: SubGoalDepth -- Depth -> CtFlavor -> EvVar -> [PredType] -> TcS StopOrContinue canTuple d fl ev tys @@ -289,9 +245,16 @@ canTuple d fl ev tys ; when (isNewEvVar evc) $ addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl') ; return ev' } +\end{code} + + +%************************************************************************ +%* * +%* Implicit Parameter Canonicalization +%* * +%************************************************************************ --- Implicit Parameter Canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} canIP :: SubGoalDepth -- Depth -> CtFlavor -> EvVar -> IPName Name -> Type -> TcS StopOrContinue @@ -332,16 +295,29 @@ same type, and at that point we can generate a flattened equality constraint between the types. (On the other hand, the types in two class constraints for the same class MAY be equal, so they need to be flattened in the first place to facilitate comparing them.) -\begin{code} --- Class Canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * +%* Class Canonicalization +%* * +%************************************************************************ -canClass :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar - -> Class -> [Type] -> TcS StopOrContinue +\begin{code} +canClass, canClassNC + :: SubGoalDepth -- Depth + -> CtFlavor -> EvVar + -> Class -> [Type] -> TcS StopOrContinue -- Precondition: EvVar is class evidence --- Note: Does NOT add superclasses, but the /caller/ is responsible for adding them! + +-- The canClassNC version is used on non-canonical constraints +-- and adds superclasses. The plain canClass version is used +-- for already-canonical class constraints (but which might have +-- been subsituted or somthing), and hence do not need superclasses + +canClassNC d fl ev cls tys + = canClass d fl ev cls tys + `andWhenContinue` emitSuperclasses + canClass d fl v cls tys = do { -- sctx <- getTcSContext ; (xis, cos) <- flattenMany d fl tys @@ -367,6 +343,20 @@ canClass d fl v cls tys , cc_tyargs = xis, cc_class = cls , cc_depth = d } else return Stop } } + +emitSuperclasses :: Ct -> TcS StopOrContinue +emitSuperclasses ct@(CDictCan { cc_id = v_new, cc_depth = d, cc_flavor = fl + , cc_tyargs = xis_new, cc_class = cls }) + -- Add superclasses of this one here, See Note [Adding superclasses]. + -- But only if we are not simplifying the LHS of a rule. + = 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 } +emitSuperclasses _ = panic "emit_superclasses of non-class!" \end{code} Note [Adding superclasses] @@ -495,10 +485,14 @@ is_improvement_pty ty = go (classifyPredType ty) \end{code} +%************************************************************************ +%* * +%* Irreducibles canonicalization +%* * +%************************************************************************ + \begin{code} --- Irreducibles canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canIrred :: SubGoalDepth -- Depth -> CtFlavor -> EvVar -> TcType -> TcS StopOrContinue -- Precondition: ty not a tuple and no other evidence form @@ -605,58 +599,7 @@ flatten d ctxt ty flatten _ _ xi@(LitTy {}) = return (xi, mkTcReflCo xi) flatten d ctxt (TyVarTy tv) - = do { ieqs <- getInertEqs - ; 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} - -Note [Non-idempotent inert substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The inert substitution is not idempotent in the broad sense. It is only idempotent in -that it cannot rewrite the RHS of other inert equalities any further. An example of such -an inert substitution is: - - [Åš] g1 : ta8 ~ ta4 - [W] g2 : ta4 ~ a5Fj - -Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on -an RHS of an equality. Now, imagine a constraint: - - [W] g3: ta8 ~ Int - -coming in. If we simply apply once the inert substitution we will get: - - [W] g3_1: ta4 ~ Int - -and because potentially ta4 is untouchable we will try to insert g3_1 in the inert set, -getting a panic since the inert only allows ONE equation per LHS type variable (as it -should). - -For this reason, when we reach to flatten a type variable, we flatten it recursively, -so that we can make sure that the inert substitution /is/ fully applied. - -This insufficient rewriting was the reason for #5668. - -\begin{code} - + = flattenTyVar d ctxt tv flatten d ctxt (AppTy ty1 ty2) = do { (xi1,co1) <- flatten d ctxt ty1 @@ -754,8 +697,62 @@ flatten d ctxt ty@(ForAllTy {}) go bound (FunTy arg res) = go bound arg || go bound res go bound (AppTy fun arg) = go bound fun || go bound arg go bound (ForAllTy tv ty) = go (bound `extendVarSet` tv) ty +\end{code} + +\begin{code} +flattenTyVar :: SubGoalDepth -> CtFlavor -> TcTyVar -> TcS (Xi, TcCoercion) +-- "Flattening" a type variable means to apply the substitution to it +flattenTyVar d ctxt tv + = do { ieqs <- getInertEqs + ; 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} + +Note [Non-idempotent inert substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inert substitution is not idempotent in the broad sense. It is only idempotent in +that it cannot rewrite the RHS of other inert equalities any further. An example of such +an inert substitution is: + + [Åš] g1 : ta8 ~ ta4 + [W] g2 : ta4 ~ a5Fj + +Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on +an RHS of an equality. Now, imagine a constraint: + + [W] g3: ta8 ~ Int + +coming in. If we simply apply once the inert substitution we will get: + + [W] g3_1: ta4 ~ Int + +and because potentially ta4 is untouchable we will try to insert g3_1 in the inert set, +getting a panic since the inert only allows ONE equation per LHS type variable (as it +should). + +For this reason, when we reach to flatten a type variable, we flatten it recursively, +so that we can make sure that the inert substitution /is/ fully applied. +This insufficient rewriting was the reason for #5668. +\begin{code} getCachedFlatEq :: TyCon -> [Xi] -> CtFlavor -> FlatEqOrigin -> TcS (Maybe (Xi, TcCoercion)) @@ -790,30 +787,43 @@ addToWork tcs_action = tcs_action >>= stop_or_emit where stop_or_emit Stop = return () stop_or_emit (ContinueWith ct) = updWorkListTcS $ extendWorkListCt ct +\end{code} + +%************************************************************************ +%* * +%* Equalities +%* * +%************************************************************************ + +\begin{code} canEqEvVarsCreated :: SubGoalDepth -> [CtFlavor] -> [EvVarCreated] -> [Type] -> [Type] -> TcS StopOrContinue -canEqEvVarsCreated _d _fl [] _ _ = return Stop -canEqEvVarsCreated d (fl:fls) (evc:evcs) (ty1:tys1) (ty2:tys2) - | isNewEvVar evc - = let do_one evc0 sy1 sy2 - | isNewEvVar evc0 - = canEq_ d fl (evc_the_evvar evc0) sy1 sy2 - | otherwise = return () - in do { _unused <- zipWith3M do_one evcs tys1 tys2 - ; canEq d fl (evc_the_evvar evc) ty1 ty2 } - | otherwise - = canEqEvVarsCreated d fls evcs tys1 tys2 -canEqEvVarsCreated _ _ _ _ _ = return Stop - - -canEq_ :: SubGoalDepth - -> CtFlavor -> EqVar -> Type -> Type -> TcS () -canEq_ d fl eqv ty1 ty2 = addToWork (canEq d fl eqv ty1 ty2) - -canEq :: SubGoalDepth - -> CtFlavor -> EqVar -> Type -> Type -> TcS StopOrContinue +canEqEvVarsCreated d fls evcs tys1 tys2 + = ASSERT( equalLength fls evcs && equalLength fls tys1 && equalLength fls tys2 ) + case filter is_new (zip4 fls evcs tys1 tys2) of + [] -> return Stop + (quad : quads) -> do { mapM_ (addToWork . do_quad) quads + ; do_quad quad } + -- For the new EvVars, add all but one to the work list + -- and return the first (if any) for futher processing + where + is_new (_, evc, _, _) = isNewEvVar evc + do_quad (fl, evc, ty1, ty2) = canEqNC d fl (evc_the_evvar evc) ty1 ty2 + -- Note the "NC": these are fresh equalities so we must be + -- careful to add their kind constraints + +------------------------- +canEqNC, canEq + :: SubGoalDepth + -> CtFlavor -> EqVar + -> Type -> Type -> TcS StopOrContinue + +canEqNC d fl ev ty1 ty2 + = canEq d fl ev ty1 ty2 + `andWhenContinue` emitKindConstraint + canEq _d fl eqv ty1 ty2 | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a @@ -849,24 +859,21 @@ canEq d fl eqv ty1 ty2 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 - kicos = map mkTcReflCo kis1 + else do + { argeqvs <- zipWithM (newEqVar fl) tys1 tys2 - ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2' ; fls <- case fl of Wanted {} -> do { _ <- setEqBind eqv - (mkTcTyConAppCo tc1 (kicos ++ map (mkTcCoVarCo . evc_the_evvar) argeqvs)) fl + (mkTcTyConAppCo tc1 (map (mkTcCoVarCo . evc_the_evvar) argeqvs)) fl ; return (map (\_ -> fl) argeqvs) } Given {} -> let do_one argeqv n = setEqBind (evc_the_evvar argeqv) (mkTcNthCo n (mkTcCoVarCo eqv)) fl - in zipWithM do_one argeqvs [(length kicos)..] + in zipWithM do_one argeqvs [0..] Derived {} -> return (map (\_ -> fl) argeqvs) - ; canEqEvVarsCreated d fls argeqvs tys1' tys2' } + ; canEqEvVarsCreated d fls argeqvs tys1 tys2 } -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify @@ -886,6 +893,7 @@ canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) canEq d fl eqv _ _ = canEqFailure d fl eqv +------------------------ -- Type application canEqAppTy :: SubGoalDepth -> CtFlavor -> EqVar -> Type -> Type -> Type -> Type @@ -911,6 +919,7 @@ canEqAppTy d fl eqv s1 t1 s2 t2 ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] } +------------------------ canEqFailure :: SubGoalDepth -> CtFlavor -> EvVar -> TcS StopOrContinue canEqFailure d fl eqv @@ -918,6 +927,64 @@ canEqFailure d fl eqv -- See Note [Combining insoluble constraints] ; emitFrozenError fl eqv d ; return Stop } + +------------------------ +emitKindConstraint :: Ct -> TcS StopOrContinue +emitKindConstraint ct + = case ct of + CTyEqCan { cc_id = ev, cc_depth = d + , cc_flavor = fl, cc_tyvar = tv + , cc_rhs = ty } + -> emit_kind_constraint ev d fl (mkTyVarTy tv) ty + + CFunEqCan { cc_id = ev, cc_depth = d + , cc_flavor = fl + , cc_fun = fn, cc_tyargs = xis1 + , cc_rhs = xi2 } + -> emit_kind_constraint ev d fl (mkTyConApp fn xis1) xi2 + + _ -> continueWith ct + where + emit_kind_constraint eqv d fl ty1 ty2 + | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, + = continueWith ct -- because then k1, k2 are BOX + + | otherwise + = ASSERT( isKind k1 && isKind k2 ) + do { keqv <- forceNewEvVar kind_co_fl (mkNakedEqPred superKind k1 k2) + ; eqv' <- forceNewEvVar fl (mkTcEqPred 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 + + ; traceTcS "Emitting kind constraint" $ + vcat [ ppr keqv <+> dcolon <+> ppr (mkEqPred k1 k2) + , ppr eqv, ppr eqv' ] + ; addToWork (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!" \end{code} Note [Combining insoluble constraints] @@ -1154,7 +1221,7 @@ canEqLeaf d fl eqv s1 s2 else return Stop } | otherwise - = do { traceTcS "canEqLeaf" $ ppr (mkEqPred (s1,s2)) + = do { traceTcS "canEqLeaf" $ ppr (mkEqPred s1 s2) ; canEqLeafOriented d fl eqv s1 s2 } where re_orient = reOrient fl @@ -1285,13 +1352,15 @@ canEqLeafTyVarLeftRec :: SubGoalDepth -> TcTyVar -> TcType -> TcS StopOrContinue canEqLeafTyVarLeftRec d fl eqv tv s2 -- eqv :: tv ~ s2 = do { traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2 - ; (xi1,co1) <- flatten d fl (mkTyVarTy tv) -- co1 :: xi1 ~ tv + ; (xi1,co1) <- flattenTyVar d fl tv -- co1 :: xi1 ~ tv ; case isTcReflCo co1 of - True -- If reflco and variable, just go on - | Just tv' <- getTyVar_maybe xi1 - -> canEqLeafTyVarLeft d fl eqv tv' s2 - _ -> -- If not a variable or not refl co, must rewrite and go on - do { delCachedEvVar eqv fl + True -> case getTyVar_maybe xi1 of + Just tv' -> canEqLeafTyVarLeft d fl eqv tv' s2 + Nothing -> canEq d fl eqv xi1 s2 + + False -> -- If not refl co, must rewrite and go on + do { traceTcS "celtlr: rewrite" (ppr xi1 $$ ppr co1) + ; delCachedEvVar eqv fl ; evc <- newEqVar fl xi1 s2 -- new_ev :: xi1 ~ s2 ; let new_ev = evc_the_evvar evc ; fl' <- case fl of @@ -1345,7 +1414,8 @@ canEqLeafTyVarLeft d fl eqv tv s2 -- eqv : tv ~ s2 ; if no_flattening_happened then if isNothing occ_check_result then - canEqFailure d fl (setVarType eqv $ mkEqPred (mkTyVarTy tv, xi2')) + canEqFailure d fl (setVarType eqv $ + mkTcEqPred (mkTyVarTy tv) xi2') else continueWith $ CTyEqCan { cc_id = eqv , cc_flavor = fl diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index ac1895fe35..f2f6059cee 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -16,6 +16,7 @@ Typechecking class declarations module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcInstanceMethodBody, mkGenericDefMethBind, + HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs, tcAddDeclCtxt, badMethodErr ) where @@ -98,7 +99,9 @@ tcClassSigs :: Name -- Name of the class -> TcM ([TcMethInfo], -- Exactly one for each method NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods - = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs + = do { traceTc "tcClassSigs 1" (ppr clas) + + ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs ; let gen_dm_env = mkNameEnv gen_dm_prs ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs @@ -112,6 +115,7 @@ tcClassSigs clas sigs def_methods | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] -- Generic signature without value binding + ; traceTc "tcClassSigs 2" (ppr clas) ; return (op_info, gen_dm_env) } where vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] @@ -120,7 +124,9 @@ tcClassSigs clas sigs def_methods dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] tc_sig genop_env (op_names, op_hs_ty) - = do { op_ty <- tcHsType op_hs_ty -- Class tyvars already in scope + = do { traceTc "ClsSig 1" (ppr op_names) + ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope + ; traceTc "ClsSig 2" (ppr op_names) ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } where f nm | nm `elemNameEnv` genop_env = GenericDM @@ -128,7 +134,7 @@ tcClassSigs clas sigs def_methods | otherwise = NoDM tc_gen_sig (op_names, gen_hs_ty) - = do { gen_op_ty <- tcHsType gen_hs_ty + = do { gen_op_ty <- tcClassSigType gen_hs_ty ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } \end{code} @@ -160,8 +166,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragFun sigs default_binds - sig_fn = mkSigFun sigs - clas_tyvars = tcSuperSkolTyVars tyvars + sig_fn = mkHsSigFun sigs + clas_tyvars = snd (tcSuperSkolTyVars tyvars) pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred @@ -178,7 +184,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name - -> SigFun -> PragFun -> ClassOpItem + -> HsSigFun -> PragFun -> ClassOpItem -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) @@ -186,7 +192,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) -tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) +tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info) = case dm_info of NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags ; return emptyBag } @@ -195,7 +201,6 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) where sel_name = idName sel_id prags = prag_fn sel_name - dm_sig_fn _ = sig_fn sel_name dm_bind = findMethodBind sel_name binds_in `orElse` pprPanic "tcDefMeth" (ppr sel_id) @@ -212,44 +217,44 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) -- Base the local_dm_name on the selector name, because -- type errors from tcInstanceMethodBody come from here - ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) - local_dm_id = mkLocalId local_dm_name local_dm_ty ; dm_id_w_inline <- addInlinePrags dm_id prags ; spec_prags <- tcSpecPrags dm_id prags + ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) + hs_ty = lookupHsSig hs_sig_fn sel_name + `orElse` pprPanic "tc_dm" (ppr sel_name) + + ; local_dm_sig <- instTcTySig hs_ty local_dm_ty local_dm_name ; warnTc (not (null spec_prags)) (ptext (sLit "Ignoring SPECIALISE pragmas on default method") <+> quotes (ppr sel_name)) ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] - dm_id_w_inline local_dm_id dm_sig_fn + dm_id_w_inline local_dm_sig IsDefaultMethod dm_bind ; return (unitBag tc_bind) } --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] - -> Id -> Id - -> SigFun -> TcSpecPrags -> LHsBind Name + -> Id -> TcSigInfo + -> TcSpecPrags -> LHsBind Name -> TcM (LHsBind Id) tcInstanceMethodBody skol_info tyvars dfun_ev_vars - meth_id local_meth_id - meth_sig_fn specs - (L loc bind) + meth_id local_meth_sig + specs (L loc bind) = do { -- Typecheck the binding, first extending the envt -- so that when tcInstSig looks up the local_meth_id to find -- its signature, we'll find it in the environment - let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) + let local_meth_id = sig_id local_meth_sig + lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind - ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; (ev_binds, (tc_bind, _, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ - tcPolyBinds TopLevel meth_sig_fn no_prag_fn - NonRecursive NonRecursive - [lm_bind] + tcPolyCheck local_meth_sig no_prag_fn NonRecursive [lm_bind] ; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = specs } @@ -289,6 +294,20 @@ instantiateMethod clas sel_id inst_tys --------------------------- +type HsSigFun = NameEnv (LHsType Name) + +emptyHsSigs :: HsSigFun +emptyHsSigs = emptyNameEnv + +mkHsSigFun :: [LSig Name] -> HsSigFun +mkHsSigFun sigs = mkNameEnv [(n, hs_ty) + | L _ (TypeSig ns hs_ty) <- sigs + , L _ n <- ns ] + +lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name) +lookupHsSig = lookupNameEnv + +--------------------------- findMethodBind :: Name -- Selector name -> LHsBinds Name -- A group of bindings -> Maybe (LHsBind Name) -- The binding diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7751ae49d2..e8691a4996 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -23,6 +23,7 @@ import DynFlags import TcRnMonad import FamInst import TcEnv +import TcTyClsDecls( tcFamTyPats ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -498,7 +499,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec -- The deriving clause of a data or newtype declaration deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, - tcdTyVars = tv_names, + tcdTyVars = hs_tvs, tcdTyPats = ty_pats })) = setSrcSpan loc $ -- Use the location of the 'deriving' item tcAddDeclCtxt decl $ @@ -512,8 +513,8 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, -- Given data T a b c = ... deriving( C d ), -- we want to drop type variables from T so that (C d (T a)) is well-kinded - ; let cls_tyvars = classTyVars cls - kind = tyVarKind (last cls_tyvars) + ; let cls_tyvars = classTyVars cls + kind = tyVarKind (last cls_tyvars) (arg_kinds, _) = splitKindFunTys kind n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop @@ -522,7 +523,9 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, inst_ty_kind = typeKind inst_ty dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop) univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs) - `minusVarSet` dropped_tvs + `minusVarSet` dropped_tvs + + ; traceTc "derivTyData" (pprTvBndrs tvs $$ ppr tc $$ ppr tc_args $$ pprTvBndrs (varSetElems $ tyVarsOfTypes tc_args) $$ ppr inst_ty) -- Check that the result really is well-kinded ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind)) @@ -556,11 +559,10 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name, get_lhs Nothing = do { tc <- tcLookupTyCon tycon_name ; let tvs = tyConTyVars tc ; return (tvs, tc, mkTyVarTys tvs) } - -- JPM: to fix - get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats - ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app - ; let (tc, tc_args) = tcSplitTyConApp tc_app - ; return (tvs, tc, tc_args) } + get_lhs (Just pats) = do { fam_tc <- tcLookupTyCon tycon_name + ; tcFamTyPats fam_tc hs_tvs pats (\_ -> return ()) $ + \ tvs' pats' _ -> + return (tvs', fam_tc, pats') } deriveTyData _other = panic "derivTyData" -- Caller ensures that only TyData can happen diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index ae320ce692..d97a0884f9 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -25,8 +25,9 @@ module TcEnv( tcExtendGhciEnv, tcExtendLetEnv, tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, - tcLookupId, tcLookupTyVar, getScopedTyVarBinds, - getInLocalScope, + tcLookupId, tcLookupTyVar, + tcLookupLcl_maybe, + getScopedTyVarBinds, getInLocalScope, wrongThingErr, pprBinders, tcExtendRecEnv, -- For knot-tying @@ -71,6 +72,7 @@ import TypeRep import Class import Name import NameEnv +import VarEnv import HscTypes import DynFlags import SrcLoc @@ -103,29 +105,27 @@ tcLookupGlobal :: Name -> TcM TyThing -- In GHCi, we may make command-line bindings (ghci> let x = True) -- that bind a GlobalId, but with an InternalName tcLookupGlobal name - = do { env <- getGblEnv - - -- Try local envt + = do { -- Try local envt + env <- getGblEnv ; case lookupNameEnv (tcg_type_env env) name of { Just thing -> return thing ; - Nothing -> do + Nothing -> - -- Try global envt - { hsc_env <- getTopEnv - ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) - ; case mb_thing of { - Just thing -> return thing ; - Nothing -> do - -- Should it have been in the local envt? - { case nameModule_maybe name of - Nothing -> notFound name -- Internal names can happen in GHCi + case nameModule_maybe name of { + Nothing -> notFound name ; -- Internal names can happen in GHCi Just mod | mod == tcg_mod env -- Names from this module - -> notFound name -- should be in tcg_type_env - | otherwise - -> tcImportDecl name -- Go find it in an interface - }}}}} + -> notFound name -- should be in tcg_type_env + | otherwise -> do + + -- Try home package table and external package table + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of + Just thing -> return thing + Nothing -> tcImportDecl name -- Go find it in an interface + }}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id tcLookupField name @@ -275,6 +275,11 @@ tcExtendRecEnv gbl_stuff thing_inside tcLookupLocated :: Located Name -> TcM TcTyThing tcLookupLocated = addLocM tcLookup +tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) +tcLookupLcl_maybe name + = do { local_env <- getLclTypeEnv + ; return (lookupNameEnv local_env name) } + tcLookup :: Name -> TcM TcTyThing tcLookup name = do local_env <- getLclTypeEnv @@ -283,11 +288,11 @@ tcLookup name = do Nothing -> AGlobal <$> tcLookupGlobal name tcLookupTyVar :: Name -> TcM TcTyVar -tcLookupTyVar name = do - thing <- tcLookup name - case thing of - ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty) - _ -> pprPanic "tcLookupTyVar" (ppr name) +tcLookupTyVar name + = do { thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return tv + _ -> pprPanic "tcLookupTyVar" (ppr name) } tcLookupId :: Name -> TcM Id -- Used when we aren't interested in the binding level, nor refinement. @@ -340,18 +345,36 @@ tcExtendKindEnvTvs bndrs thing_inside = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) (thing_inside bndrs) +----------------------- +-- Scoped type and kind variables tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside - = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside + = tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside -tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r +tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r tcExtendTyVarEnv2 binds thing_inside - = tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside - -getScopedTyVarBinds :: TcM [(Name, TcType)] + = tc_extend_local_env [(name, ATyVar name tv) | (name, tv) <- binds] $ + do { env <- getLclEnv + ; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) } + ; setLclEnv env' thing_inside } + where + add_tidy_tvs env = foldl add env binds + + -- We initialise the "tidy-env", used for tidying types before printing, + -- by building a reverse map from the in-scope type variables to the + -- OccName that the programmer originally used for them + add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv + add (env,subst) (name, tyvar) + = case tidyOccName env (nameOccName name) of + (env', occ') -> (env', extendVarEnv subst tyvar tyvar') + where + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' + +getScopedTyVarBinds :: TcM [(Name, TcTyVar)] getScopedTyVarBinds = do { lcl_env <- getLclEnv - ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] } + ; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] } \end{code} @@ -398,8 +421,8 @@ tcExtendGhciEnv ids thing_inside | id <- ids] thing_inside where - is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel - | otherwise = NotTopLevel + is_top id | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel + | otherwise = NotTopLevel tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a @@ -435,8 +458,10 @@ tc_extend_local_env extra_env thing_inside emptyVarSet NotTopLevel -> id_tvs where - id_tvs = tcTyVarsOfType (idType id) - get_tvs (_, ATyVar _ ty) = tcTyVarsOfType ty -- See Note [Global TyVars] + id_tvs = tyVarsOfType (idType id) + get_tvs (_, ATyVar _ tv) -- See Note [Global TyVars] + = tyVarsOfType (tyVarKind tv) `extendVarSet` tv + get_tvs other = pprPanic "get_tvs" (ppr other) -- Note [Global TyVars] @@ -446,6 +471,8 @@ tc_extend_local_env extra_env thing_inside -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. + -- + -- Nor must we generalise g over any kind variables free in r's kind tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) tcExtendGlobalTyVars gtv_var extra_global_tvs @@ -553,15 +580,13 @@ thTopLevelId id = isGlobalId id || isExternalName (idName id) %************************************************************************ \begin{code} -tcGetDefaultTys :: Bool -- True <=> interactive context - -> TcM ([Type], -- Default types +tcGetDefaultTys :: TcM ([Type], -- Default types (Bool, -- True <=> Use overloaded strings Bool)) -- True <=> Use extended defaulting rules -tcGetDefaultTys interactive +tcGetDefaultTys = do { dflags <- getDynFlags ; let ovl_strings = xopt Opt_OverloadedStrings dflags - extended_defaults = interactive - || xopt Opt_ExtendedDefaultRules dflags + extended_defaults = xopt Opt_ExtendedDefaultRules dflags -- See also Trac #1974 flags = (ovl_strings, extended_defaults) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 5d5413d145..16e3fb546c 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -39,13 +39,12 @@ import VarEnv import Bag import Maybes import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) +import SrcLoc ( noSrcSpan ) import Util import FastString import Outputable import DynFlags import Data.List ( partition, mapAccumL ) -import Data.Either ( partitionEithers ) --- import Control.Monad ( when ) \end{code} %************************************************************************ @@ -333,7 +332,7 @@ groupErrs mk_err (ct1 : rest) -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = msg $$ nest 2 (pprArising orig) +addArising orig msg = hang msg 2 (pprArising orig) pprWithArising :: [Ct] -> (WantedLoc, SDoc) -- Print something like @@ -345,8 +344,8 @@ pprWithArising [] = panic "pprWithArising" pprWithArising (ct:cts) | null cts - = (loc, hang (pprEvVarTheta [cc_id ct]) - 2 (pprArising (ctLocOrigin (ctWantedLoc ct)))) + = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) + (pprEvVarTheta [cc_id ct])) | otherwise = (loc, vcat (map ppr_one (ct:cts))) where @@ -481,7 +480,7 @@ mkTyVarEqErr ctxt ct oriented tv1 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 + | not (k2 `tcIsSubKind` k1) -- Kind error = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) -- Occurs check @@ -576,15 +575,14 @@ misMatchOrCND ctxt ct oriented ty1 ty2 -- or there is no context, don't report the context = misMatchMsg oriented ty1 ty2 | otherwise - = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) + = couldNotDeduce givens ([mkEqPred ty1 ty2], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) - = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) - 2 (pprArising orig) + = vcat [ addArising orig (ptext (sLit "Could not deduce") <+> pprTheta wanteds) , vcat (pp_givens givens)] pp_givens :: [([EvVar], GivenLoc)] -> [SDoc] @@ -621,11 +619,14 @@ tyVarExtraInfoMsg implics ty | otherwise -- Normal case = empty - where - ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, ptext (sLit "at") <+> ppr loc]] + ppr_skol given_loc tv_loc + = case skol_info of + UnkSkol -> ptext (sLit "is an unknown type variable") + _ -> sep [ ptext (sLit "is a rigid type variable bound by"), + sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] + where + skol_info = ctLocOrigin given_loc kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy kindErrorMsg ty1 ty2 @@ -658,8 +659,8 @@ misMatchMsg oriented ty1 ty2 mkExpectedActualMsg :: Type -> Type -> SDoc mkExpectedActualMsg exp_ty act_ty - = vcat [ text "Expected type" <> colon <+> ppr exp_ty - , text " Actual type" <> colon <+> ppr act_ty ] + = vcat [ text "Expected type:" <+> ppr exp_ty + , text " Actual type:" <+> ppr act_ty ] \end{code} Note [Non-injective type functions] @@ -682,108 +683,117 @@ Warn of loopy local equalities that were dropped. \begin{code} mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg mkDictErr ctxt cts - = do { inst_envs <- tcGetInstEnvs - ; 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]) } } + = ASSERT( not (null cts) ) + do { inst_envs <- tcGetInstEnvs + ; lookups <- mapM (lookup_cls_inst inst_envs) cts + ; let (no_inst_cts, overlap_cts) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; mkErrorReport ctxt err } where - (ct1:_) = cts - orig = ctLocOrigin (ctWantedLoc ct1) - - givens = getUserGivens ctxt - - mk_no_inst_fixes is_ambig cts - | null givens = show_fixes (fixes2 ++ fixes3) - | otherwise = show_fixes (fixes1 ++ fixes2 ++ fixes3) + no_givens = null (getUserGivens ctxt) + is_no_inst (ct, (matches, unifiers, _)) + = no_givens + && null matches + && (null unifiers || all (not . isAmbiguousTyVar) (varSetElems (tyVarsOfCt ct))) + + lookup_cls_inst inst_envs ct + = do { tys_flat <- mapM quickFlattenTy tys + -- Note [Flattening in error message generation] + ; return (ct, lookupInstEnv inst_envs clas tys_flat) } where - 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 - [] -> [] - [_] -> [sep [ptext (sLit "add an instance declaration for"), - pprTheta instance_dicts]] - _ -> [sep [ptext (sLit "add instance declarations for"), - pprTheta instance_dicts]] - fixes3 = case orig of - DerivOrigin -> [drv_fix] - _ -> [] + (clas, tys) = getClassPredTys (ctPred ct) - drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"), - nest 2 $ ptext (sLit "so you can specify the instance context yourself")] +mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) + -> TcM (ReportErrCtxt, SDoc) +-- Report an overlap error if this class constraint results +-- from an overlap (returning Left clas), otherwise return (Right pred) +mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell)) + | null matches -- No matches but perhaps several unifiers + = do { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt [ct] + ; return (ctxt', cannot_resolve_msg is_ambig ambig_msg) } - 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 $$ - vcat [ ptext (sLit "or") <+> ppr_skol orig - | orig <- origs ] - ] ] - | otherwise = [] + | not safe_haskell -- Some matches => overlap errors + = return (ctxt, overlap_msg) - ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) - ppr_skol skol_info = ppr skol_info + | otherwise + = return (ctxt, safe_haskell_msg) + where + orig = ctLocOrigin (ctWantedLoc ct) + pred = ctPred ct + (clas, tys) = getClassPredTys pred + ispecs = [ispec | (ispec, _) <- matches] + givens = getUserGivens ctxt + all_tyvars = all isTyVarTy tys + + cannot_resolve_msg has_ambig_tvs ambig_msg + = vcat [ addArising orig (no_inst_herald <+> pprParendType pred) + , vcat (pp_givens givens) + , if has_ambig_tvs && (not (null unifiers) || not (null givens)) + then ambig_msg $$ potential_msg + else empty + , show_fixes (inst_decl_fixes + ++ add_to_ctxt_fixes has_ambig_tvs + ++ drv_fixes) ] + + potential_msg + | null unifiers = empty + | otherwise + = hang (if isSingleton unifiers + then ptext (sLit "Note: there is a potential instance available:") + else ptext (sLit "Note: there are several potential instances:")) + 2 (ppr_insts unifiers) + + add_to_ctxt_fixes has_ambig_tvs + | not has_ambig_tvs && all_tyvars + , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) + = [sep [ ptext (sLit "add") <+> pprParendType pred + <+> ptext (sLit "to the context of") + , nest 2 $ ppr_skol orig $$ + vcat [ ptext (sLit "or") <+> ppr_skol orig + | orig <- origs ] ] ] + | otherwise = [] + + ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc) + ppr_skol skol_info = ppr skol_info -- Do not suggest adding constraints to an *inferred* type signature! - get_good_orig ic = case ctLocOrigin (ic_loc ic) of + get_good_orig ic = case ctLocOrigin (ic_loc ic) of SigSkol (InfSigCtxt {}) _ -> Nothing origin -> Just origin + no_inst_herald + | null givens && null matches = ptext (sLit "No instance for") + | otherwise = ptext (sLit "Could not deduce") - 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 + inst_decl_fixes + | all_tyvars = [] + | otherwise = [ sep [ ptext (sLit "add an instance declaration for") + , pprParendType pred] ] -mkOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin - -> Ct -> TcM (Either Ct SDoc) --- Report an overlap error if this class constraint results --- 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] + drv_fixes = case orig of + DerivOrigin -> [drv_fix] + _ -> [] - ; case lookupInstEnv inst_envs clas tys_flat of - ([], _, _) -> return (Left ct) -- No match - res -> return (Right (mk_overlap_msg res)) } - where - (clas, tys) = getClassPredTys (ctPred ct) + drv_fix = hang (ptext (sLit "use a standalone 'deriving instance' declaration,")) + 2 (ptext (sLit "so you can specify the instance context yourself")) -- Normal overlap error - mk_overlap_msg (matches, unifiers, False) + overlap_msg = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") <+> pprType (mkClassPred clas tys)) - , sep [ptext (sLit "Matching instances") <> colon, - nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] , if not (null matching_givens) then - sep [ptext (sLit "Matching givens (or their superclasses)") <> colon + sep [ptext (sLit "Matching givens (or their superclasses):") , nest 2 (vcat matching_givens)] else empty + , sep [ptext (sLit "Matching instances:"), + nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] + , if null matching_givens && isSingleton matches && null unifiers then -- Intuitively, some given matched the wanted in their -- flattened or rewritten (from given equalities) form @@ -791,7 +801,7 @@ mkOverlap ctxt inst_envs orig ct -- constraints are non-flat and non-rewritten so we -- simply report back the whole given -- context. Accelerate Smart.hs showed this problem. - sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon + sep [ ptext (sLit "There exists a (perhaps superclass) match:") , nest 2 (vcat (pp_givens givens))] else empty @@ -827,13 +837,13 @@ mkOverlap ctxt inst_envs orig ct -> any ev_var_matches (immSuperClasses clas' tys') Nothing -> False - -- Overlap error because of Safe Haskell (first match should be the most - -- specific match) - mk_overlap_msg (matches, _unifiers, True) + -- Overlap error because of Safe Haskell (first + -- match should be the most specific match) + safe_haskell_msg = ASSERT( length matches > 1 ) vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") <+> pprType (mkClassPred clas tys)) - , sep [ptext (sLit "The matching instance is") <> colon, + , sep [ptext (sLit "The matching instance is:"), nest 2 (pprInstance $ head ispecs)] , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" , ptext $ sLit "overlap instances from the same module, however it" @@ -841,8 +851,21 @@ mkOverlap ctxt inst_envs orig ct , nest 2 (vcat [pprInstances $ tail ispecs]) ] ] - where - ispecs = [ispec | (ispec, _) <- matches] + +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))] + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts insts + = pprInstances (take 3 insts) $$ dot_dot_message + where + n_extra = length insts - 3 + dot_dot_message + | n_extra <= 0 = empty + | otherwise = ptext (sLit "...plus") + <+> speakNOf n_extra (ptext (sLit "other")) ---------------------- quickFlattenTy :: TcType -> TcM TcType @@ -939,14 +962,15 @@ mkAmbigMsg ctxt cts -- if it is not already set! ] -getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +getSkolemInfo :: [Implication] -> TcTyVar -> GivenLoc -- 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 + CtLoc UnkSkol noSrcSpan [] + getSkolemInfo (implic:implics) tv - | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic) + | tv `elem` ic_skols implic = ic_loc implic | otherwise = getSkolemInfo implics tv ----------------------- @@ -993,20 +1017,21 @@ find_thing tidy_env ignore_it (ATcId { tct_id = id }) ppr (getSrcLoc id)))] ; return (tidy_env', Just msg) } } -find_thing tidy_env ignore_it (ATyVar tv ty) - = do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty +find_thing tidy_env ignore_it (ATyVar name tv) + = do { ty <- zonkTcTyVar tv + ; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty ; if ignore_it tidy_ty then return (tidy_env, Nothing) else do { let -- The name tv is scoped, so we don't need to tidy it - msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff + msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff , nest 2 bound_at] eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty - , getOccName tv == getOccName tv' = empty + , getOccName name == getOccName tv' = empty | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv) + bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name) ; return (tidy_env1, Just msg) } } diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 7a4a1b5843..571643c9f8 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -470,6 +470,7 @@ data EvTerm | 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] | EvLit EvLit -- The dictionary for class "NatI" @@ -487,7 +488,6 @@ data EvLit 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 @@ -497,8 +497,7 @@ 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. - +the simplifier is in TcCanonical.emitKindConstraint. Note [EvBinds/EvTerm] ~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index abcff85d7d..488e65458c 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -46,7 +46,6 @@ import DataCon import Name import TyCon import Type -import Kind( splitKiTyVars ) import TcEvidence import Var import VarSet @@ -199,7 +198,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty -- Remember to extend the lexical type-variable environment ; (gen_fn, expr') <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> - tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` skol_tvs) $ -- See Note [More instantiated than scoped] in TcBinds tcMonoExprNC expr res_ty @@ -648,25 +647,25 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons is_fixed_tv tv = tv `elemVarSet` fixed_tvs - mk_inst_ty subst tv result_inst_ty - | is_fixed_tv tv = return result_inst_ty -- Same as result type - | otherwise = newFlexiTyVarTy (subst (tyVarKind tv)) -- Fresh type, of correct kind - - ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs - - ; let (con1_r_kvs, con1_r_tvs) = splitKiTyVars con1_tvs - n_kinds = length con1_r_kvs - (result_inst_r_kis, result_inst_r_tys) = splitAt n_kinds result_inst_tys - ; scrut_inst_r_kis <- zipWithM (mk_inst_ty (TcType.substTy (zipTopTvSubst [] []))) con1_r_kvs result_inst_r_kis - -- IA0_NOTE: we have to build the kind substitution - ; let kind_subst = TcType.substTy (zipTopTvSubst con1_r_kvs scrut_inst_r_kis) - ; scrut_inst_r_tys <- zipWithM (mk_inst_ty kind_subst) con1_r_tvs result_inst_r_tys - - ; let scrut_inst_tys = scrut_inst_r_kis ++ scrut_inst_r_tys - rec_res_ty = TcType.substTy result_inst_env con1_res_ty - con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys - scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys - scrut_ty = TcType.substTy scrut_subst con1_res_ty + + mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType) + -- Deals with instantiation of kind variables + -- c.f. TcMType.tcInstTyVarsX + mk_inst_ty subst (tv, result_inst_ty) + | is_fixed_tv tv -- Same as result type + = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) + | otherwise -- Fresh type, of correct kind + = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv)) + ; return (extendTvSubst subst tv new_ty, new_ty) } + + ; (_, result_inst_tys, result_subst) <- tcInstTyVars con1_tvs + + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst + (con1_tvs `zip` result_inst_tys) + + ; let rec_res_ty = TcType.substTy result_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty + con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys ; co_res <- unifyType rec_res_ty res_ty @@ -833,6 +832,10 @@ tcApp (L loc (HsVar fun)) args res_ty , [arg] <- args = tcTagToEnum loc fun arg res_ty + | fun `hasKey` seqIdKey + , [arg1,arg2] <- args + = tcSeq loc fun arg1 arg2 res_ty + tcApp fun args res_ty = do { -- Type-check the function ; (fun1, fun_tau) <- tcInferFun fun @@ -892,7 +895,7 @@ tcInferFun fun -- Zonk the function type carefully, to expose any polymorphism -- E.g. (( \(x::forall a. a->a). blah ) e) -- We can see the rank-2 type of the lambda in time to genrealise e - ; fun_ty' <- zonkTcTypeCarefully fun_ty + ; fun_ty' <- zonkTcType fun_ty ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' ; return (mkLHsWrap wrap fun, rho) } @@ -1119,6 +1122,18 @@ constructors of F [Int] but here we have to do it explicitly. It's all grotesquely complicated. \begin{code} +tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name + -> TcRhoType -> TcM (HsExpr TcId) +-- (seq e1 e2) :: res_ty +-- We need a special typing rule because res_ty can be unboxed +tcSeq loc fun_name arg1 arg2 res_ty + = do { fun <- tcLookupId fun_name + ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1) + ; arg2' <- tcMonoExpr arg2 res_ty + ; let fun' = L loc (HsWrap ty_args (HsVar fun)) + ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty + ; return (HsApp (L loc (HsApp fun' arg1')) arg2') } + tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 10de6acea5..7379ca2ae9 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -122,15 +122,10 @@ normaliseFfiType' env ty0 = go [] ty0 panic "normaliseFfiType': Got more GREs than expected" _ -> return False - when (not newtypeOK) $ - -- later: stop_here - addWarnTc (ptext (sLit "newtype") <+> quotes (ppr tc) <+> - ptext (sLit "is used in an FFI declaration,") $$ - ptext (sLit "but its constructor is not in scope.") $$ - ptext (sLit "This will become an error in GHC 7.6.1.")) - - let nt_co = mkAxInstCo (newTyConCo tc) tys - add_co nt_co rec_nts' nt_rhs + if newtypeOK + then do let nt_co = mkAxInstCo (newTyConCo tc) tys + add_co nt_co rec_nts' nt_rhs + else children_only | isFamilyTyCon tc -- Expand open tycons , (co, ty) <- normaliseTcApp env tc tys @@ -138,11 +133,7 @@ normaliseFfiType' env ty0 = go [] ty0 = add_co co rec_nts ty | otherwise - = return (mkReflCo ty, ty) - -- If we have reached an ordinary (non-newtype) type constructor, - -- we are done. Note that we don't need to normalise the arguments, - -- because whether an FFI type is legal or not depends only on - -- the top-level type constructor (e.g. "Ptr a" is valid for all a). + = children_only where tc_key = getUnique tc children_only = do xs <- mapM (go rec_nts) tys @@ -272,13 +263,18 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty + case target of + StaticTarget _ _ False + | not (null arg_tys) -> + addErrTc (text "`value' imports cannot have function types") + _ -> return () return idecl -- This makes a convenient place to check -- that the C identifier is valid for C checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget str _) = do +checkCTarget (StaticTarget str _ _) = do checkCg checkCOrAsmOrLlvmOrDotNetOrInterp check (isCLabelString str) (badCName str) diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 70d841e5ed..481c4ed727 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,7 +11,9 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \begin{code} -{-# OPTIONS -fno-warn-tabs -XScopedTypeVariables #-} +{-# 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 -- detab the module (please do the detabbing in a separate patch). See diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 1fbb7df856..9493669e55 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -99,7 +99,7 @@ genGenericRepExtras tc mod = | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] distinctAbstractTyConRhs + buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs NonRecursive False NoParentTyCon let metaDTyCon = mkTyCon d_name diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index bb3a994669..75dedd0622 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -27,17 +27,14 @@ module TcHsSyn ( TcId, TcIdSet, zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar, - zonkId, zonkTopBndrs + zonkId, zonkTopBndrs, + emptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes ) where #include "HsVersions.h" --- friends: -import HsSyn -- oodles of it - --- others: +import HsSyn import Id - import TcRnMonad import PrelNames import TcType @@ -46,7 +43,6 @@ import TcEvidence import TysPrim import TysWiredIn import Type -import Kind import DataCon import Name import NameSet @@ -225,6 +221,9 @@ extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) ty = ZonkEnv zonk_ty (extendVarEnv ty_env ty ty) id_env +mkTyVarZonkEnv :: [TyVar] -> ZonkEnv +mkTyVarZonkEnv tvs = ZonkEnv zonkTypeZapping (mkVarEnv [(tv,tv) | tv <- tvs]) emptyVarEnv + setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv setZonkType (ZonkEnv _ ty_env id_env) zonk_ty = ZonkEnv zonk_ty ty_env id_env @@ -293,14 +292,12 @@ zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) zonkTyBndrsX = mapAccumLM zonkTyBndrX zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced zonkTyBndrX env tv - = do { tv' <- zonkTyBndr env tv - ; return (extendTyZonkEnv1 env tv', tv') } - -zonkTyBndr :: ZonkEnv -> TyVar -> TcM TyVar -zonkTyBndr env tv = do { ki <- zonkTcTypeToType env (tyVarKind tv) - ; return (setVarType tv ki) } + ; let tv' = mkTyVar (tyVarName tv) ki + ; return (extendTyZonkEnv1 env tv', tv') } \end{code} @@ -1154,16 +1151,17 @@ zonkEvBind env (EvBind var term) | Just ty <- isTcReflCo_maybe co -> do { zty <- zonkTcTypeToType env ty - ; let var' = setVarType var (mkEqPred (zty,zty)) + ; let var' = setVarType var (mkEqPred zty zty) ; return (EvBind var' (EvCoercion (mkTcReflCo zty))) } -- Fast path for variable-variable bindings -- NB: could be optimized further! (e.g. SymCo cv) | Just cv <- getTcCoVar_maybe co - -> do { let cv' = zonkIdOcc env cv -- Just lazily look up + -> do { let cv' = zonkIdOcc env cv -- Just lazily look up term' = EvCoercion (TcCoVarCo cv') var' = setVarType var (varType cv') ; return (EvBind var' term') } + -- Ugly safe and slow path _ -> do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var ; term' <- zonkEvTerm env term @@ -1278,9 +1276,10 @@ zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env) = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar) where - zonk_bound_tyvar tv = case lookupVarEnv tv_env tv of - Nothing -> mkTyVarTy tv - Just tv' -> mkTyVarTy tv' + zonk_bound_tyvar tv -- Look up in the env just as we do for Ids + = case lookupVarEnv tv_env tv of + Nothing -> mkTyVarTy tv + Just tv' -> mkTyVarTy tv' zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys @@ -1290,7 +1289,7 @@ zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker -- Works on both types and kinds zonkTvCollecting unbound_tv_set tv = do { poly_kinds <- xoptM Opt_PolyKinds - ; if isKiVar tv && not poly_kinds then defaultKindVarToStar tv + ; if isKindVar tv && not poly_kinds then defaultKindVarToStar tv else do { tv' <- zonkQuantifiedTyVar tv ; tv_set <- readMutVar unbound_tv_set @@ -1302,10 +1301,10 @@ zonkTypeZapping :: UnboundTyVarZonker -- It zaps unbound type variables to (), or some other arbitrary type -- Works on both types and kinds zonkTypeZapping tv - = do { let ty = if isKiVar tv + = do { let ty = if isKindVar tv -- ty is actually a kind, zonk to AnyK then anyKind - else anyTypeOfKind (tyVarKind tv) + else anyTypeOfKind (defaultKind (tyVarKind tv)) ; writeMetaTyVar tv ty ; return ty } diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 7d6dfeb293..1f776cebbd 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -14,24 +14,26 @@ module TcHsType ( tcHsSigType, tcHsSigTypeNC, tcHsDeriv, tcHsVectInst, - tcHsInstHead, tcHsQuantifiedType, + tcHsInstHead, UserTypeCtxt(..), - -- Kind checking - kcHsTyVars, kcHsSigType, kcHsLiftedSigType, - kcLHsType, kcCheckLHsType, kcHsContext, kcApps, - kindGeneralizeKind, kindGeneralizeKinds, + -- Type checking type and class decls + kcTyClTyVars, tcTyClTyVars, + tcHsConArgType, tcDataKindSig, + tcClassSigType, - -- Sort checking - scDsLHsKind, scDsLHsMaybeKind, - - -- Typechecking kinded types - tcHsType, tcCheckHsType, - tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, tcTyVarBndrsKindGen, dsHsType, - tcDataKindSig, tcTyClTyVars, + -- Kind-checking types + -- No kind generalisation, no checkValidType + tcHsTyVarBndrs, tcHsTyVarBndrsGen , + tcHsLiftedType, + tcLHsType, tcCheckLHsType, + tcHsContext, tcInferApps, tcHsArgTys, ExpKind(..), ekConstraint, expArgKind, checkExpectedKind, + kindGeneralize, + + -- Sort-checking kinds + tcLHsKind, -- Pattern type signatures tcHsPatSigType, tcPatSig @@ -40,31 +42,30 @@ module TcHsType ( #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( kcSpliceType ) +import {-# SOURCE #-} TcSplice( tcSpliceType ) #endif import HsSyn -import RnHsSyn +import TcHsSyn ( zonkTcTypeToType, emptyZonkEnv ) import TcRnMonad import RnEnv ( dataKindsErr ) -import TcHsSyn ( mkZonkTcTyVar ) import TcEvidence( HsWrapper ) import TcEnv import TcMType import TcUnify import TcIface import TcType -import {- Kind parts of -} Type +import Type import Kind +import TypeRep( mkNakedTyConApp ) import Var import VarSet import TyCon import DataCon import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName ) import Class -import RdrName ( rdrNameSpace, nameRdrName ) import Name -import NameSet +import NameEnv import TysWiredIn import BasicTypes import SrcLoc @@ -73,7 +74,7 @@ import Util import UniqSupply import Outputable import FastString -import Control.Monad ( unless ) +import Control.Monad ( unless, when, zipWithM ) \end{code} @@ -155,105 +156,68 @@ the TyCon being defined. %************************************************************************ %* * -\subsection{Checking types} + Check types AND do validity checking %* * %************************************************************************ \begin{code} tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type - -- Do kind checking, and hoist for-alls to the top -- NB: it's important that the foralls that come from the top-level -- HsForAllTy in hs_ty occur *first* in the returned type. -- See Note [Scoped] with TcSigInfo -tcHsSigType ctxt hs_ty +tcHsSigType ctxt hs_ty = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ tcHsSigTypeNC ctxt hs_ty -tcHsSigTypeNC ctxt hs_ty - = do { kinded_ty <- case expectedKindInCtxt ctxt of - Nothing -> fmap fst (kc_lhs_type_fresh hs_ty) - Just k -> kc_lhs_type hs_ty (EK k (ptext (sLit "Expected"))) +tcHsSigTypeNC ctxt (L loc hs_ty) + = setSrcSpan loc $ -- The "In the type..." context + -- comes from the caller; hence "NC" + do { kind <- case expectedKindInCtxt ctxt of + Nothing -> newMetaKindVar + Just k -> return k -- The kind is checked by checkValidType, and isn't necessarily -- of kind * in a Template Haskell quote eg [t| Maybe |] - ; ty <- tcHsKindedType kinded_ty - ; checkValidType ctxt ty - ; return ty } --- Like tcHsType, but takes an expected kind -tcCheckHsType :: LHsType Name -> Kind -> TcM Type -tcCheckHsType hs_ty exp_kind - = do { kinded_ty <- kcCheckLHsType hs_ty (EK exp_kind (ptext (sLit "Expected"))) - ; ty <- tcHsKindedType kinded_ty - ; return ty } + ; ty <- tcCheckHsTypeAndGen hs_ty kind + -- Generalise here: see Note [Kind generalisation] -tcHsType :: LHsType Name -> TcM Type --- kind check and desugar --- no validity checking because of knot-tying -tcHsType hs_ty - = do { (kinded_ty, _) <- kc_lhs_type_fresh hs_ty - ; ty <- tcHsKindedType kinded_ty - ; return ty } + -- Zonk to expose kind information to checkValidType + ; ty <- zonkTcType ty + ; checkValidType ctxt ty + ; return ty } +----------------- tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) --- Typecheck an instance head. We can't use --- tcHsSigType, because it's not a valid user type. +-- Like tcHsSigTypeNC, but for an instance head. tcHsInstHead ctxt lhs_ty@(L loc hs_ty) - = setSrcSpan loc $ -- No need for an "In the type..." context - -- because that comes from the caller - do { kinded_ty <- kc_hs_type hs_ty ekConstraint - ; ty <- ds_type kinded_ty - ; let (tvs, theta, tau) = tcSplitSigmaTy ty - ; case getClassPredTys_maybe tau of - Nothing -> failWithTc (ptext (sLit "Malformed instance type")) - Just (clas,tys) -> do { checkValidInstance ctxt lhs_ty tvs theta clas tys - ; return (tvs, theta, clas, tys) } } - -tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type) --- Behave very like type-checking (HsForAllTy sig_tvs hs_ty), --- except that we want to keep the tvs separate -tcHsQuantifiedType tv_names hs_ty - = kcHsTyVars tv_names $ \ tv_names' -> - do { kc_ty <- kcHsSigType hs_ty - ; tcTyVarBndrs tv_names' $ \ tvs -> - do { ty <- dsHsType kc_ty - ; return (tvs, ty) } } - --- Used for the deriving(...) items -tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) -tcHsDeriv = tc_hs_deriv [] - -tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name - -> TcM ([TyVar], Class, [Type]) -tc_hs_deriv tv_names1 (HsForAllTy _ tv_names2 (L _ []) (L _ ty)) - = -- Funny newtype deriving form - -- forall a. C [a] - -- where C has arity 2. Hence can't use regular functions - tc_hs_deriv (tv_names1 ++ tv_names2) ty - -tc_hs_deriv tv_names ty - | Just (cls_name, hs_tys) <- splitHsClassTy_maybe ty - = kcHsTyVars tv_names $ \ tv_names' -> - do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind hs_tys - ; tcTyVarBndrsKindGen tv_names' $ \ tyvars -> - do { arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (tyvars, cls, arg_tys) }} + = setSrcSpan loc $ -- The "In the type..." context comes from the caller + do { ty <- tcCheckHsTypeAndGen hs_ty constraintKind + ; ty <- zonkTcType ty + ; checkValidInstance ctxt lhs_ty ty } - | otherwise - = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr ty) +----------------- +tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) +-- Like tcHsSigTypeNC, but for the ...deriving( ty ) clause +tcHsDeriv hs_ty + = do { kind <- newMetaKindVar + ; ty <- tcCheckHsTypeAndGen hs_ty kind + -- Funny newtype deriving form + -- forall a. C [a] + -- where C has arity 2. Hence any-kinded result + ; ty <- zonkTcType ty + ; let (tvs, pred) = splitForAllTys ty + ; case getClassPredTys_maybe pred of + Just (cls, tys) -> return (tvs, cls, tys) + Nothing -> failWithTc (ptext (sLit "Illegal deriving item") <+> quotes (ppr hs_ty)) } -- Used for 'VECTORISE [SCALAR] instance' declarations -- tcHsVectInst :: LHsType Name -> TcM (Class, [Type]) tcHsVectInst ty | Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty - = do { cls_kind <- kcClass cls_name - ; (tys, _res_kind) <- kcApps cls_name cls_kind tys - ; arg_tys <- dsHsTypes tys - ; cls <- tcLookupClass cls_name - ; return (cls, arg_tys) - } + = do { (cls, cls_kind) <- tcClass cls_name + ; (arg_tys, _res_kind) <- tcInferApps cls_name cls_kind tys + ; return (cls, arg_tys) } | otherwise = failWithTc $ ptext (sLit "Malformed instance type") \end{code} @@ -262,373 +226,480 @@ tcHsVectInst ty type and class declarations, when we have to separate kind-checking, desugaring, and validity checking -\begin{code} -kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) - -- Used for type signatures -kcHsSigType ty = addKcTypeCtxt ty $ kcArgType ty -kcHsLiftedSigType ty = addKcTypeCtxt ty $ kcLiftedType ty - -tcHsKindedType :: LHsType Name -> TcM Type - -- Don't do kind checking, nor validity checking. - -- This is used in type and class decls, where kinding is - -- done in advance, and validity checking is done later - -- [Validity checking done later because of knot-tying issues.] -tcHsKindedType hs_ty = dsHsType hs_ty - -tcHsBangType :: LHsType Name -> TcM Type --- Permit a bang, but discard it --- Input type has already been kind-checked -tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty -tcHsBangType ty = tcHsKindedType ty - -tcHsKindedContext :: LHsContext Name -> TcM ThetaType --- Used when we are expecting a ClassContext (i.e. no implicit params) --- Does not do validity checking, like tcHsKindedType -tcHsKindedContext hs_theta = addLocM (mapM dsHsType) hs_theta -\end{code} - %************************************************************************ %* * - The main kind checker: kcHsType + The main kind checker: no validity checks here %* * %************************************************************************ First a couple of simple wrappers for kcHsType \begin{code} +tcClassSigType :: LHsType Name -> TcM Type +tcClassSigType lhs_ty@(L _ hs_ty) + = addTypeCtxt lhs_ty $ + do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind + ; zonkTcTypeToType emptyZonkEnv ty } + +tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type +-- Permit a bang, but discard it +tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty) + -- Newtypes can't have bangs, but we don't check that + -- until checkValidDataCon, so do not want to crash here + +tcHsConArgType DataType bty = tcHsArgType (getBangType bty) + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd + --------------------------- -kcLiftedType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be a *lifted* *type* -kcLiftedType ty = kc_lhs_type ty ekLifted - -kcArgs :: SDoc -> [LHsType Name] -> Kind -> TcM [LHsType Name] -kcArgs what tys kind - = sequence [ kc_lhs_type ty (expArgKind what kind n) - | (ty,n) <- tys `zip` [1..] ] +tcHsArgTys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +tcHsArgTys what tys kinds + = sequence [ addTypeCtxt ty $ + tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] + +tc_hs_arg_tys :: SDoc -> [LHsType Name] -> [Kind] -> TcM [TcType] +-- Just like tcHsArgTys but without the addTypeCtxt +tc_hs_arg_tys what tys kinds + = sequence [ tc_lhs_type ty (expArgKind what kind n) + | (ty,kind,n) <- zip3 tys kinds [1..] ] --------------------------- -kcArgType :: LHsType Name -> TcM (LHsType Name) --- The type ty must be an *arg* *type* (lifted or unlifted) -kcArgType ty = kc_lhs_type ty ekArg +tcHsArgType, tcHsLiftedType :: LHsType Name -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsArgType ty = addTypeCtxt ty $ tc_lhs_type ty ekArg +tcHsLiftedType ty = addTypeCtxt ty $ tc_lhs_type ty ekLifted + +-- Like tcHsType, but takes an expected kind +tcCheckLHsType :: LHsType Name -> Kind -> TcM Type +tcCheckLHsType hs_ty exp_kind + = addTypeCtxt hs_ty $ + tc_lhs_type hs_ty (EK exp_kind (ptext (sLit "Expected"))) + +tcLHsType :: LHsType Name -> TcM (TcType, TcKind) +-- Called from outside: set the context +tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type ty) --------------------------- -kcCheckLHsType :: LHsType Name -> ExpKind -> TcM (LHsType Name) -kcCheckLHsType ty kind = addKcTypeCtxt ty $ kc_lhs_type ty kind +tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type +-- Input type is HsType, not LhsType; the caller adds the context +-- Typecheck a type signature, and kind-generalise it +-- The result is not necessarily zonked, and has not been checked for validity +tcCheckHsTypeAndGen hs_ty kind + = do { ty <- tc_hs_type hs_ty (EK kind (ptext (sLit "Expected"))) + ; kvs <- kindGeneralize (tyVarsOfType ty) + ; return (mkForAllTys kvs ty) } \end{code} -Like tcExpr, kc_hs_type takes an expected kind which it unifies with +Like tcExpr, tc_hs_type takes an expected kind which it unifies with the kind it figures out. When we don't know what kind to expect, we use -kc_lhs_type_fresh, to first create a new meta kind variable and use that as +tc_lhs_type_fresh, to first create a new meta kind variable and use that as the expected kind. \begin{code} -kcLHsType :: LHsType Name -> TcM (LHsType Name, TcKind) --- Called from outside: set the context -kcLHsType ty = addKcTypeCtxt ty (kc_lhs_type_fresh ty) - -kc_lhs_type_fresh :: LHsType Name -> TcM (LHsType Name, TcKind) -kc_lhs_type_fresh ty = do - kv <- newMetaKindVar - r <- kc_lhs_type ty (EK kv (ptext (sLit "Expected"))) - return (r, kv) - -kc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [LHsType Name] -kc_lhs_types tys_w_kinds = mapM (uncurry kc_lhs_type) tys_w_kinds - -kc_lhs_type :: LHsType Name -> ExpKind -> TcM (LHsType Name) -kc_lhs_type (L span ty) exp_kind +tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind) +tc_infer_lhs_type ty = + do { kv <- newMetaKindVar + ; r <- tc_lhs_type ty (EK kv (ptext (sLit "Expected"))) + ; return (r, kv) } + +tc_lhs_type :: LHsType Name -> ExpKind -> TcM TcType +tc_lhs_type (L span ty) exp_kind = setSrcSpan span $ - do { traceTc "kc_lhs_type" (ppr ty <+> ppr exp_kind) - ; ty' <- kc_hs_type ty exp_kind - ; return (L span ty') } - -kc_hs_type :: HsType Name -> ExpKind -> TcM (HsType Name) -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 = do - (ty, k) <- kcTyVar name - checkExpectedKind ty k exp_kind - return ty - -kc_hs_type (HsListTy ty) exp_kind = do - ty' <- kcLiftedType ty - checkExpectedKind ty liftedTypeKind exp_kind - return (HsListTy ty') - -kc_hs_type (HsPArrTy ty) exp_kind = do - ty' <- kcLiftedType ty - checkExpectedKind ty liftedTypeKind exp_kind - return (HsPArrTy ty') - -kc_hs_type (HsKindSig ty sig_k) exp_kind = do - sig_k' <- scDsLHsKind sig_k - ty' <- kc_lhs_type ty - (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) - checkExpectedKind ty sig_k' exp_kind - return (HsKindSig ty' sig_k) + do { traceTc "tc_lhs_type:" (ppr ty $$ ppr exp_kind) + ; tc_hs_type ty exp_kind } + +tc_lhs_types :: [(LHsType Name, ExpKind)] -> TcM [TcType] +tc_lhs_types tys_w_kinds = mapM (uncurry tc_lhs_type) tys_w_kinds + +------------------------------------------ +tc_hs_type :: HsType Name -> ExpKind -> TcM TcType +tc_hs_type (HsParTy ty) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsDocTy ty _) exp_kind = tc_lhs_type ty exp_kind +tc_hs_type (HsQuasiQuoteTy {}) _ = panic "tc_hs_type: qq" -- Eliminated by renamer +tc_hs_type (HsBangTy {}) _ = panic "tc_hs_type: bang" -- Unwrapped by con decls +tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + +---------- Functions and applications +tc_hs_type hs_ty@(HsTyVar name) exp_kind + = do { (ty, k) <- tcTyVar name + ; checkExpectedKind hs_ty k exp_kind + ; return ty } + +tc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) + = do { ty1' <- tc_lhs_type ty1 (EK argTypeKind ctxt) + ; ty2' <- tc_lhs_type ty2 (EK openTypeKind ctxt) + ; checkExpectedKind ty liftedTypeKind exp_kind + ; return (mkFunTy ty1' ty2') } + +tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind + = do { (op', op_kind) <- tcTyVar op + ; tys' <- tcCheckApps hs_ty l_op op_kind [ty1,ty2] exp_kind + ; return (mkNakedAppTys op' tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] + ; (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty + ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind + ; return (mkNakedAppTys fun_ty' arg_tys') } + -- mkNakedAppTys: see Note [Zonking inside the knot] + +--------- Foralls +tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind + = tcHsTyVarBndrs hs_tvs $ \ tvs' -> + -- Do not kind-generalise here! See Note [Kind generalisation] + do { ctxt' <- tcHsContext context + ; ty' <- tc_lhs_type ty exp_kind + -- Why exp_kind? See Note [Body kind of forall] + ; return (mkSigmaTy tvs' ctxt' ty') } + +--------- Lists, arrays, and tuples +tc_hs_type hs_ty@(HsListTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon listTyCon + ; return (mkListTy tau_ty) } + +tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind + = do { tau_ty <- tc_lhs_type elt_ty ekLifted + ; checkExpectedKind hs_ty liftedTypeKind exp_kind + ; checkWiredInTyCon parrTyCon + ; return (mkPArrTy tau_ty) } -- See Note [Distinguishing tuple kinds] in HsTypes -kc_hs_type ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) - | isConstraintOrLiftedKind exp_k -- (NB: not zonking, to avoid left-right bias) - = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys exp_k - ; return $ if isConstraintKind exp_k - then HsTupleTy HsConstraintTuple tys' - else HsTupleTy HsBoxedTuple tys' } +-- See Note [Inferring tuple kinds] +tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) + -- (NB: not zonking before looking at exp_k, to avoid left-right bias) + | isConstraintKind exp_k = tc_tuple hs_ty HsConstraintTuple tys exp_kind + | isLiftedTypeKind exp_k = tc_tuple hs_ty HsBoxedTuple tys exp_kind | otherwise - -- It is not clear from the context if it's * or Constraint, - -- so we infer the kind from the arguments = do { k <- newMetaKindVar - ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k + ; tau_tys <- tc_hs_arg_tys (ptext (sLit "a tuple")) tys (repeat k) ; k' <- zonkTcKind k - ; if isConstraintKind k' - then do { checkExpectedKind ty k' exp_kind - ; return (HsTupleTy HsConstraintTuple tys') } - -- If it's not clear from the arguments that it's Constraint, then - -- it must be *. Check the arguments again to give good error messages + ; if isConstraintKind k' then + finish_tuple hs_ty HsConstraintTuple tau_tys exp_kind + else if isLiftedTypeKind k' then + finish_tuple hs_ty HsBoxedTuple tau_tys exp_kind + else + tc_tuple hs_ty HsBoxedTuple tys exp_kind } + -- It's not clear what the kind is, so assume *, and + -- check the arguments again to give good error messages -- in eg. `(Maybe, Maybe)` - else do { tys'' <- kcArgs (ptext (sLit "a tuple")) tys liftedTypeKind - ; checkExpectedKind ty liftedTypeKind exp_kind - ; return (HsTupleTy HsBoxedTuple tys'') } } -{- -Note that we will still fail to infer the correct kind in this case: - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint +tc_hs_type hs_ty@(HsTupleTy tup_sort tys) exp_kind + = tc_tuple hs_ty tup_sort tys exp_kind -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. --} +--------- Promoted lists and tuples +tc_hs_type hs_ty@(HsExplicitListTy _k tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let taus = map fst tks + ; kind <- unifyKinds (ptext (sLit "In a promoted list")) tks + ; checkExpectedKind hs_ty (mkPromotedListTy kind) exp_kind + ; return (foldr (mk_cons kind) (mk_nil kind) taus) } + where + mk_cons k a b = mkTyConApp (buildPromotedDataCon consDataCon) [k, a, b] + mk_nil k = mkTyConApp (buildPromotedDataCon nilDataCon) [k] + +tc_hs_type hs_ty@(HsExplicitTupleTy _ tys) exp_kind + = do { tks <- mapM tc_infer_lhs_type tys + ; let n = length tys + kind_con = promotedTupleTyCon BoxedTuple n + ty_con = promotedTupleDataCon BoxedTuple n + (taus, ks) = unzip tks + tup_k = mkTyConApp kind_con ks + ; checkExpectedKind hs_ty tup_k exp_kind + ; return (mkTyConApp ty_con (ks ++ taus)) } + +--------- Constraint types +tc_hs_type ipTy@(HsIParamTy n ty) exp_kind + = do { ty' <- tc_lhs_type ty + (EK liftedTypeKind (ptext (sLit "The type argument of the implicit parameter had"))) + ; checkExpectedKind ipTy constraintKind exp_kind + ; return (mkIPPred n ty') } + +tc_hs_type ty@(HsEqTy ty1 ty2) exp_kind + = do { (ty1', kind1) <- tc_infer_lhs_type ty1 + ; (ty2', kind2) <- tc_infer_lhs_type ty2 + ; checkExpectedKind ty2 kind2 + (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) + ; checkExpectedKind ty constraintKind exp_kind + ; return (mkNakedTyConApp eqTyCon [kind1, ty1', ty2']) } + +--------- Misc +tc_hs_type (HsKindSig ty sig_k) exp_kind + = do { sig_k' <- tcLHsKind sig_k + ; checkExpectedKind ty sig_k' exp_kind + ; tc_lhs_type ty + (EK sig_k' (ptext (sLit "An enclosing kind signature specified"))) } + +tc_hs_type (HsCoreTy ty) exp_kind + = do { checkExpectedKind ty (typeKind ty) exp_kind + ; return ty } + + +#ifdef GHCI /* Only if bootstrapped */ +-- This looks highly bogus to me +tc_hs_type hs_ty@(HsSpliceTy sp fvs _) exp_kind + = do { (ty, kind) <- tcSpliceType sp fvs + ; checkExpectedKind hs_ty kind exp_kind + +-- ; kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) +-- kind +-- -- See Note [Kind of a type splice] + ; return ty } +#else +tc_hs_type ty@(HsSpliceTy {}) _exp_kind + = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) +#endif + +tc_hs_type (HsWrapTy {}) _exp_kind + = panic "tc_hs_type HsWrapTy" -- We kind checked something twice -kc_hs_type ty@(HsTupleTy tup_sort tys) exp_kind - = do { tys' <- kcArgs cxt_doc tys arg_kind - ; checkExpectedKind ty out_kind exp_kind - ; return (HsTupleTy tup_sort tys') } +tc_hs_type hs_ty@(HsTyLit tl) exp_kind = do + let (ty,k) = case tl of + HsNumTy n -> (mkNumLitTy n, typeNatKind) + HsStrTy s -> (mkStrLitTy s, typeStringKind) + checkExpectedKind hs_ty k exp_kind + return ty + +--------------------------- +tc_tuple :: HsType Name -> HsTupleSort -> [LHsType Name] -> ExpKind -> TcM TcType +-- Invariant: tup_sort is not HsBoxedOrConstraintTuple +tc_tuple hs_ty tup_sort tys exp_kind + = do { tau_tys <- tc_hs_arg_tys cxt_doc tys (repeat arg_kind) + ; finish_tuple hs_ty tup_sort tau_tys exp_kind } where arg_kind = case tup_sort of HsBoxedTuple -> liftedTypeKind HsUnboxedTuple -> argTypeKind HsConstraintTuple -> constraintKind - _ -> panic "kc_hs_type arg_kind" - out_kind = case tup_sort of - HsUnboxedTuple -> ubxTupleKind - _ -> arg_kind + _ -> panic "tc_hs_type arg_kind" cxt_doc = case tup_sort of HsBoxedTuple -> ptext (sLit "a tuple") HsUnboxedTuple -> ptext (sLit "an unboxed tuple") HsConstraintTuple -> ptext (sLit "a constraint tuple") - _ -> panic "kc_hs_type tup_sort" - -kc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) = do - ty1' <- kc_lhs_type ty1 (EK argTypeKind ctxt) - ty2' <- kc_lhs_type ty2 (EK openTypeKind ctxt) - checkExpectedKind ty liftedTypeKind exp_kind - return (HsFunTy ty1' ty2') - -kc_hs_type ty@(HsOpTy ty1 (_, l_op@(L loc op)) ty2) exp_kind = do - (wop, op_kind) <- kcTyVar op - [ty1',ty2'] <- kcCheckApps l_op op_kind [ty1,ty2] ty exp_kind - let op' = case wop of - HsTyVar name -> (WpKiApps [], L loc name) - HsWrapTy wrap (HsTyVar name) -> (wrap, L loc name) - _ -> panic "kc_hs_type HsOpTy" - return (HsOpTy ty1' op' ty2') - -kc_hs_type ty@(HsAppTy ty1 ty2) exp_kind = do - let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] - (fun_ty', fun_kind) <- kc_lhs_type_fresh fun_ty - arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind - return (mkHsAppTys fun_ty' arg_tys') - -kc_hs_type ipTy@(HsIParamTy n ty) exp_kind = do - ty' <- kc_lhs_type ty - (EK liftedTypeKind - (ptext (sLit "The type argument of the implicit parameter had"))) - checkExpectedKind ipTy constraintKind exp_kind - return (HsIParamTy n ty') - -kc_hs_type ty@(HsEqTy ty1 ty2) exp_kind = do - (ty1', kind1) <- kc_lhs_type_fresh ty1 - (ty2', kind2) <- kc_lhs_type_fresh ty2 - checkExpectedKind ty2 kind2 - (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) - checkExpectedKind ty constraintKind exp_kind - return (HsEqTy ty1' ty2') - -kc_hs_type (HsCoreTy ty) exp_kind = do - checkExpectedKind ty (typeKind ty) exp_kind - return (HsCoreTy ty) - -kc_hs_type (HsForAllTy exp tv_names context ty) exp_kind - = kcHsTyVars tv_names $ \ tv_names' -> - do { ctxt' <- kcHsContext context - ; ty' <- kc_lhs_type ty exp_kind - -- The body of a forall is usually a type, but in principle - -- there's no reason to prohibit *unlifted* types. - -- In fact, GHC can itself construct a function with an - -- unboxed tuple inside a for-all (via CPR analyis; see - -- typecheck/should_compile/tc170). - -- - -- Moreover in instance heads we get forall-types with - -- kind Constraint. - -- - -- Really we should check that it's a type of value kind - -- {*, Constraint, #}, but I'm not doing that yet - -- Example that should be rejected: - -- f :: (forall (a:*->*). a) Int - ; return (HsForAllTy exp tv_names' ctxt' ty') } - -kc_hs_type (HsBangTy b ty) exp_kind - = do { ty' <- kc_lhs_type ty exp_kind - ; return (HsBangTy b ty') } - -kc_hs_type ty@(HsRecTy _) _exp_kind - = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty) - -- Record types (which only show up temporarily in constructor signatures) - -- should have been removed by now - -#ifdef GHCI /* Only if bootstrapped */ -kc_hs_type (HsSpliceTy sp fvs _) exp_kind = do - (ty, k) <- kcSpliceType sp fvs - checkExpectedKind ty k exp_kind - return ty -#else -kc_hs_type ty@(HsSpliceTy {}) _exp_kind = - failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) -#endif - -kc_hs_type (HsQuasiQuoteTy {}) _exp_kind = - panic "kc_hs_type" -- Eliminated by renamer - --- Remove the doc nodes here, no need to worry about the location since --- it's the same for a doc node and its child type node -kc_hs_type (HsDocTy ty _) exp_kind - = kc_hs_type (unLoc 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 (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 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)) - -kc_hs_type ty@(HsTyLit tl) exp_kind = do - let k = case tl of - HsNumTy _ -> typeNatKind - HsStrTy _ -> typeStringKind - checkExpectedKind ty k exp_kind - return ty - -kc_hs_type (HsWrapTy {}) _exp_kind = - panic "kc_hs_type HsWrapTy" -- We kind checked something twice + _ -> panic "tc_hs_type tup_sort" +finish_tuple :: HsType Name -> HsTupleSort -> [TcType] -> ExpKind -> TcM TcType +finish_tuple hs_ty tup_sort tau_tys exp_kind + = do { checkExpectedKind hs_ty res_kind exp_kind + ; checkWiredInTyCon tycon + ; return (mkTyConApp tycon tau_tys) } + where + tycon = tupleTyCon con (length tau_tys) + con = case tup_sort of + HsUnboxedTuple -> UnboxedTuple + HsBoxedTuple -> BoxedTuple + HsConstraintTuple -> ConstraintTuple + _ -> panic "tc_hs_type HsTupleTy" + + res_kind = case tup_sort of + HsUnboxedTuple -> ubxTupleKind + HsBoxedTuple -> liftedTypeKind + HsConstraintTuple -> constraintKind + _ -> panic "tc_hs_type arg_kind" --------------------------- -kcApps :: Outputable a +tcInferApps :: Outputable a => a -> TcKind -- Function kind -> [LHsType Name] -- Arg types - -> TcM ([LHsType Name], TcKind) -- Kind-checked args -kcApps the_fun fun_kind args - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args - ; args' <- kc_lhs_types args_w_kinds + -> TcM ([TcType], TcKind) -- Kind-checked args +tcInferApps the_fun fun_kind args + = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) fun_kind args + ; args' <- tc_lhs_types args_w_kinds ; return (args', res_kind) } -kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name] - -> HsType Name -- The type being checked (for err messages only) - -> ExpKind -- Expected kind - -> TcM ([LHsType Name]) -kcCheckApps the_fun fun_kind args ty exp_kind - = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args - ; args_w_kinds' <- kc_lhs_types args_w_kinds - ; checkExpectedKind ty res_kind exp_kind - ; return args_w_kinds' } - +tcCheckApps :: Outputable a + => HsType Name -- The type being checked (for err messages only) + -> a -- The function + -> TcKind -> [LHsType Name] -- Fun kind and arg types + -> ExpKind -- Expected kind + -> TcM [TcType] +tcCheckApps hs_ty the_fun fun_kind args exp_kind + = do { (arg_tys, res_kind) <- tcInferApps the_fun fun_kind args + ; checkExpectedKind hs_ty res_kind exp_kind + ; return arg_tys } --------------------------- -splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) -splitFunKind _ _ fk [] = return ([], fk) -splitFunKind the_fun arg_no fk (arg:args) - = do { mb_fk <- matchExpectedFunKind fk - ; case mb_fk of - Nothing -> failWithTc too_many_args - Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args - ; return ((arg - ,expArgKind (quotes the_fun) ak arg_no) - :aks ,rk) } } +splitFunKind :: SDoc -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) +splitFunKind the_fun fun_kind args + = go 1 fun_kind args where + go _ fk [] = return ([], fk) + go arg_no fk (arg:args) + = do { mb_fk <- matchExpectedFunKind fk + ; case mb_fk of + Nothing -> failWithTc too_many_args + Just (ak,fk') -> do { (aks, rk) <- go (arg_no+1) fk' args + ; let exp_kind = expArgKind (quotes the_fun) ak arg_no + ; return ((arg, exp_kind) : aks, rk) } } + too_many_args = quotes the_fun <+> ptext (sLit "is applied to too many type arguments") + --------------------------- -kcHsContext :: LHsContext Name -> TcM (LHsContext Name) -kcHsContext ctxt = wrapLocM (mapM kcHsLPredType) ctxt +tcHsContext :: LHsContext Name -> TcM [PredType] +tcHsContext ctxt = mapM tcHsLPredType (unLoc ctxt) -kcHsLPredType :: LHsType Name -> TcM (LHsType Name) -kcHsLPredType pred = kc_lhs_type pred ekConstraint +tcHsLPredType :: LHsType Name -> TcM PredType +tcHsLPredType pred = tc_lhs_type pred ekConstraint --------------------------- -kcTyVar :: Name -> TcM (HsType Name, TcKind) +tcTyVar :: Name -> TcM (TcType, TcKind) -- See Note [Type checking recursive type and class declarations] -- in TcTyClsDecls -kcTyVar name -- Could be a tyvar, a tycon, or a datacon +tcTyVar name -- Could be a tyvar, a tycon, or a datacon = do { traceTc "lk1" (ppr name) ; thing <- tcLookup name ; traceTc "lk2" (ppr name <+> ppr thing) ; case thing of - ATyVar _ ty -> wrap_mono (typeKind ty) - AThing kind -> wrap_poly kind - AGlobal (ATyCon tc) -> wrap_poly (tyConKind tc) - AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly - _ -> wrongThingErr "type" thing name } + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + AThing kind -> do { tc <- get_loopy_tc name + ; inst_tycon (mkNakedTyConApp tc) kind } + -- mkNakedTyConApp: see Note [Zonking inside the knot] + + AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) + + AGlobal (ADataCon dc) + | isPromotableType ty -> inst_tycon (mkTyConApp tc) (tyConKind tc) + | otherwise -> failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") + <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) + where + ty = dataConUserType dc + tc = buildPromotedDataCon dc + + ANothing -> failWithTc (ptext (sLit "Promoted kind") <+> + quotes (ppr name) <+> + ptext (sLit "used in a mutually recursive group")) + + _ -> wrongThingErr "type" thing name } where - wrap_mono kind = do { traceTc "lk3" (ppr name <+> dcolon <+> ppr kind) - ; return (HsTyVar name, kind) } - wrap_poly kind - | null kvs = wrap_mono kind + get_loopy_tc name + = do { env <- getGblEnv + ; case lookupNameEnv (tcg_type_env env) name of + Just (ATyCon tc) -> return tc + _ -> return (aThingErr "tcTyVar" name) } + + inst_tycon :: ([Type] -> Type) -> Kind -> TcM (Type, Kind) + -- Instantiate the polymorphic kind + -- Lazy in the TyCon + inst_tycon mk_tc_app kind + | null kvs + = return (mk_tc_app [], ki_body) | otherwise = do { traceTc "lk4" (ppr name <+> dcolon <+> ppr kind) - ; kvs' <- mapM (const newMetaKindVar) kvs - ; let ki = substKiWith kvs kvs' ki_body - ; return (HsWrapTy (WpKiApps kvs') (HsTyVar name), ki) } - where (kvs, ki_body) = splitForAllTys kind - --- IA0_TODO: this function should disapear, and use the dcPromoted field of DataCon -kcDataCon :: DataCon -> TcM TcKind -kcDataCon dc = do - let ty = dataConUserType dc - unless (isPromotableType ty) $ promoteErr dc ty - let ki = promoteType ty - traceTc "prm" (ppr ty <+> ptext (sLit "~~>") <+> ppr ki) - return ki - where - promoteErr dc ty = failWithTc (quotes (ppr dc) <+> ptext (sLit "of type") - <+> quotes (ppr ty) <+> ptext (sLit "is not promotable")) - -kcClass :: Name -> TcM TcKind -kcClass cls = do -- Must be a class - thing <- tcLookup cls - case thing of - AThing kind -> return kind - AGlobal (ATyCon tc) - | Just cls <- tyConClass_maybe tc -> return (tyConKind (classTyCon cls)) - _ -> wrongThingErr "class" thing cls + ; ks <- mapM (const newMetaKindVar) kvs + ; return (mk_tc_app ks, substKiWith kvs ks ki_body) } + where + (kvs, ki_body) = splitForAllTys kind + +tcClass :: Name -> TcM (Class, TcKind) +tcClass cls -- Must be a class + = do { thing <- tcLookup cls + ; case thing of + AThing kind -> return (aThingErr "tcClass" cls, kind) + AGlobal (ATyCon tc) + | Just cls <- tyConClass_maybe tc + -> return (cls, tyConKind tc) + _ -> wrongThingErr "class" thing cls } + + +aThingErr :: String -> Name -> b +-- The type checker for types is sometimes called simply to +-- do *kind* checking; and in that case it ignores the type +-- returned. Which is a good thing since it may not be available yet! +aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x) \end{code} +Note [Zonking inside the knot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are checking the argument types of a data constructor. We +must zonk the types before making the DataCon, because once built we +can't change it. So we must traverse the type. -%************************************************************************ -%* * - Desugaring -%* * -%************************************************************************ +BUT the parent TyCon is knot-tied, so we can't look at it yet. + +So we must be careful not to use "smart constructors" for types that +look at the TyCon or Class involved. Hence the use of mkNakedXXX +functions. + +This is sadly delicate. + +Note [Body kind of a forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type, but in principle +there's no reason to prohibit *unlifted* types. +In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all (via CPR analyis; see +typecheck/should_compile/tc170). + +Moreover in instance heads we get forall-types with +kind Constraint. + +Moreover if we have a signature + f :: Int# +then we represent it as (HsForAll Implicit [] [] Int#). And this must +be legal! We can't drop the empty forall until *after* typechecking +the body because of kind polymorphism: + Typeable :: forall k. k -> Constraint + data Apply f t = Apply (f t) + -- Apply :: forall k. (k -> *) -> k -> * + instance Typeable Apply where ... +Then the dfun has type + df :: forall k. Typeable ((k->*) -> k -> *) (Apply k) + + f :: Typeable Apply + + f :: forall (t:k->*) (a:k). t a -> t a + + class C a b where + op :: a b -> Typeable Apply + + data T a = MkT (Typeable Apply) + | T2 a + T :: * -> * + MkT :: forall k. (Typeable ((k->*) -> k -> *) (Apply k)) -> T a + + f :: (forall (k:BOX). forall (t:: k->*) (a:k). t a -> t a) -> Int + f :: (forall a. a -> Typeable Apply) -> Int + +So we *must* keep the HsForAll on the instance type + HsForAll Implicit [] [] (Typeable Apply) +so that we do kind generalisation on it. + +Really we should check that it's a type of value kind +{*, Constraint, #}, but I'm not doing that yet +Example that should be rejected: + f :: (forall (a:*->*). a) Int + +Note [Inferring tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the Check the arguments again to give good error messages +in eg. `(Maybe, Maybe)` + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. Note [Desugaring types] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -662,120 +733,6 @@ Moreover (a) spurious ! annotations. (b) a class used as a type -\begin{code} - -zonkTcKindToKind :: TcKind -> TcM Kind --- When zonking a TcKind to a kind we instantiate kind variables to AnyK -zonkTcKindToKind = zonkType (mkZonkTcTyVar (\ _ -> return anyKind) mkTyVarTy) - -dsHsType :: LHsType Name -> TcM Type --- All HsTyVarBndrs in the intput type are kind-annotated --- See Note [Desugaring types] -dsHsType ty = ds_type (unLoc ty) - -ds_type :: HsType Name -> TcM Type --- See Note [Desugaring types] -ds_type ty@(HsTyVar _) - = ds_app ty [] - -ds_type (HsParTy ty) -- Remove the parentheses markers - = dsHsType ty - -ds_type ty@(HsBangTy {}) -- No bangs should be here - = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) - -ds_type ty@(HsRecTy {}) -- No bangs should be here - = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty) - -ds_type (HsKindSig ty _) - = dsHsType ty -- Kind checking done already - -ds_type (HsListTy ty) = do - tau_ty <- dsHsType ty - checkWiredInTyCon listTyCon - return (mkListTy tau_ty) - -ds_type (HsPArrTy ty) = do - tau_ty <- dsHsType ty - checkWiredInTyCon parrTyCon - return (mkPArrTy tau_ty) - -ds_type (HsTupleTy hs_con tys) = do - con <- case hs_con of - HsUnboxedTuple -> return UnboxedTuple - HsBoxedTuple -> return BoxedTuple - HsConstraintTuple -> return ConstraintTuple - _ -> panic "ds_type HsTupleTy" - -- failWithTc (ptext (sLit "Unexpected tuple component kind:") <+> ppr kind') - let tycon = tupleTyCon con (length tys) - tau_tys <- dsHsTypes tys - checkWiredInTyCon tycon - return (mkTyConApp tycon tau_tys) - -ds_type (HsFunTy ty1 ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - return (mkFunTy tau_ty1 tau_ty2) - -ds_type (HsOpTy ty1 (wrap, (L span op)) ty2) = - setSrcSpan span (ds_app (HsWrapTy wrap (HsTyVar op)) [ty1,ty2]) - -ds_type ty@(HsAppTy _ _) - = ds_app ty [] - -ds_type (HsIParamTy n ty) = do - tau_ty <- dsHsType ty - return (mkIPPred n tau_ty) - -ds_type (HsEqTy ty1 ty2) = do - tau_ty1 <- dsHsType ty1 - tau_ty2 <- dsHsType ty2 - return (mkEqPred (tau_ty1, tau_ty2)) - -ds_type (HsForAllTy _ tv_names ctxt ty) - = tcTyVarBndrsKindGen tv_names $ \ tyvars -> do - theta <- mapM dsHsType (unLoc ctxt) - tau <- dsHsType ty - return (mkSigmaTy tyvars theta tau) - -ds_type (HsDocTy ty _) -- Remove the doc comment - = dsHsType ty - -ds_type (HsSpliceTy _ _ kind) - = do { kind' <- zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind) mkTyVarTy) - kind - -- See Note [Kind of a type splice] - ; newFlexiTyVarTy kind' } - -ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer -ds_type (HsCoreTy ty) = return ty - -ds_type (HsExplicitListTy kind tys) = do - kind' <- zonkTcKindToKind kind - ds_tys <- mapM dsHsType tys - return $ - 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 (buildPromotedDataCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys') - -ds_type (HsTyLit tl) = return $ case tl of - HsNumTy n -> mkNumLitTy n - HsStrTy s -> mkStrLitTy s - -ds_type (HsWrapTy (WpKiApps kappas) ty) = do - tau <- ds_type ty - kappas' <- mapM zonkTcKindToKind kappas - return (mkAppTys tau kappas') - -dsHsTypes :: [LHsType Name] -> TcM [Type] -dsHsTypes arg_tys = mapM dsHsType arg_tys -\end{code} - Note [Kind of a type splice] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider these terms, each with TH type splice inside: @@ -795,41 +752,13 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -ds_app :: HsType Name -> [LHsType Name] -> TcM Type -ds_app (HsAppTy ty1 ty2) tys - = ds_app (unLoc ty1) (ty2:tys) - -ds_app ty tys = do - arg_tys <- dsHsTypes tys - case ty of - HsTyVar fun -> ds_var_app fun arg_tys - _ -> do fun_ty <- ds_type ty - return (mkAppTys fun_ty arg_tys) - -ds_var_app :: Name -> [Type] -> TcM Type --- See Note [Type checking recursive type and class declarations] --- in TcTyClsDecls -ds_var_app name arg_tys - | isTvNameSpace (rdrNameSpace (nameRdrName name)) - = do { thing <- tcLookup name - ; case thing of - ATyVar _ ty -> return (mkAppTys ty arg_tys) - _ -> wrongThingErr "type" thing name } - - | otherwise - = do { thing <- tcLookupGlobal name - ; case thing of - ATyCon tc -> return (mkTyConApp tc arg_tys) - ADataCon dc -> return (mkTyConApp (buildPromotedDataCon dc) arg_tys) - _ -> wrongThingErr "type" (AGlobal thing) name } - -addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a +addTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisble ones and ones user's won't grok -addKcTypeCtxt (L _ other_ty) thing = addErrCtxt (typeCtxt other_ty) thing - -typeCtxt :: HsType Name -> SDoc -typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty) +addTypeCtxt (L _ ty) thing + = addErrCtxt doc thing + where + doc = ptext (sLit "In the type") <+> quotes (ppr ty) \end{code} %************************************************************************ @@ -854,16 +783,30 @@ then we'd also need since we only have BOX for a super kind) \begin{code} -kcHsTyVars :: [LHsTyVarBndr Name] - -> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated - -- They scope over the thing inside - -> TcM r -kcHsTyVars tvs thing_inside - = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs - ; tcExtendKindEnvTvs kinded_tvs thing_inside } - -kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) --- Return a *kind-annotated* binder, whose PostTcKind is +bindScopedKindVars :: [LHsTyVarBndr Name] -> TcM a -> TcM a +-- Given some tyvar binders like [a (b :: k -> *) (c :: k)] +-- bind each scoped kind variable (k in this case) to a fresh +-- kind skolem variable +bindScopedKindVars hs_tvs thing_inside + = tcExtendTyVarEnv kvs thing_inside + where + kvs :: [KindVar] -- All skolems + kvs = [ mkKindSigVar kv + | L _ (KindedTyVar _ (HsBSig _ kvs) _) <- hs_tvs + , kv <- kvs ] + +tcHsTyVarBndrs :: [LHsTyVarBndr Name] + -> ([TyVar] -> TcM r) + -> TcM r +-- Bind the type variables to skolems, each with a meta-kind variable kind +tcHsTyVarBndrs hs_tvs thing_inside + = bindScopedKindVars hs_tvs $ + do { tvs <- mapM tcHsTyVarBndr hs_tvs + ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs) + ; tcExtendTyVarEnv tvs (thing_inside tvs) } + +tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TyVar +-- Return a type variable -- initialised with a kind variable. -- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind -- in it. We aren't yet sure whether the binder is a *type* variable or a *kind* @@ -874,49 +817,72 @@ kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- instance C (a,b) where -- type F (a,b) c = ... -- Here a,b will be in scope when processing the associated type instance for F. -kcHsTyVar tyvar = do in_scope <- getInLocalScope - if in_scope (hsTyVarName tyvar) - then do inscope_tyvar <- tcLookupTyVar (hsTyVarName tyvar) - return (UserTyVar (tyVarName inscope_tyvar) - (tyVarKind inscope_tyvar)) - else kcHsTyVar' tyvar - where - kcHsTyVar' (UserTyVar name _) = UserTyVar name <$> newMetaKindVar - kcHsTyVar' (KindedTyVar name kind _) = do - kind' <- scDsLHsKind kind - return (KindedTyVar name kind kind') +tcHsTyVarBndr (L _ hs_tv) + = do { let name = hsTyVarName hs_tv + ; mb_tv <- tcLookupLcl_maybe name + ; case mb_tv of { + Just (ATyVar _ tv) -> return tv ; + _ -> do + { kind <- case hs_tv of + UserTyVar {} -> newMetaKindVar + KindedTyVar _ (HsBSig kind _) _ -> tcLHsKind kind + ; return (mkTyVar name kind) } } } ------------------ -tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking - -> ([TyVar] -> TcM r) - -> TcM r --- Used when type-checking types/classes/type-decls --- Brings into scope immutable TyVars, not mutable ones that require later zonking --- Fix #5426: avoid abstraction over kinds containing # or (#) -tcTyVarBndrs bndrs thing_inside = do - tyvars <- mapM (zonk . hsTyVarNameKind . unLoc) bndrs - tcExtendTyVarEnv tyvars (thing_inside tyvars) - where - zonk (name, kind) - = do { kind' <- zonkTcKind kind - ; checkTc (noHashInKind kind') (ptext (sLit "Kind signature contains # or (#)")) - ; return (mkTyVar name kind') } - -tcTyVarBndrsKindGen :: [LHsTyVarBndr Name] -> ([TyVar] -> TcM r) -> TcM r --- tcTyVarBndrsKindGen [(f :: ?k -> *), (a :: ?k)] thing_inside --- calls thing_inside with [(k :: BOX), (f :: k -> *), (a :: k)] -tcTyVarBndrsKindGen bndrs thing_inside - = do { let kinds = map (hsTyVarKind . unLoc) bndrs - ; (kvs, zonked_kinds) <- kindGeneralizeKinds kinds - ; let tyvars = zipWith mkTyVar (map hsLTyVarName bndrs) zonked_kinds - ktvs = kvs ++ tyvars -- See Note [Kinds of quantified type variables] - ; traceTc "tcTyVarBndrsKindGen" (ppr (bndrs, kvs, tyvars)) - ; tcExtendTyVarEnv ktvs (thing_inside ktvs) } +tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] + -> TcM (TcTyVarSet, r) -- Result + free tyvars of thing inside + -> TcM ([TyVar], r) -- Generalised kind variables + -- + zonked tyvars + result result +-- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside +-- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)] +tcHsTyVarBndrsGen hs_tvs thing_inside + = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) + ; (tvs, (ftvs, res)) <- tcHsTyVarBndrs hs_tvs $ \ tvs -> + do { res <- thing_inside + ; return (tvs, res) } + ; let kinds = map tyVarKind tvs + ; kvs' <- kindGeneralize (tyVarsOfTypes kinds `unionVarSet` + (ftvs `delVarSetList` tvs)) + ; zonked_kinds <- mapM zonkTcKind kinds + ; let tvs' = zipWith setTyVarKind tvs zonked_kinds + -- See Note [Kinds of quantified type variables] + ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs)) + ; return (kvs' ++ tvs', res) } + +------------------- +kindGeneralize :: TyVarSet -> TcM [KindVar] +kindGeneralize tkvs + = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked + ; tidy_env <- tcInitTidyEnv + ; tkvs <- zonkTyVarsAndFV tkvs + ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs) + + (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify + -- We do not get a later chance to tidy! + + ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs) + zonkQuantifiedTyVars tidy_kvs_to_quantify } \end{code} +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, becuase it requires a more +polymorphic argument. + Note [Kinds of quantified type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsKindGen quantifies over a specified list of type variables, +tcTyVarBndrsGen quantifies over a specified list of type variables, *and* over the kind variables mentioned in the kinds of those tyvars. Note that we must zonk those kinds (obviously) but less obviously, we @@ -931,22 +897,75 @@ Reason: we're going to turn this into a for-all type, which the type checker will then instantiate, and instantiate does not look through unification variables! -Hence using zonked_kinds when forming 'tyvars'. +Hence using zonked_kinds when forming tvs'. \begin{code} +-------------------- +-- getInitialKind has made a suitably-shaped kind for the type or class +-- Unpack it, and attribute those kinds to the type variables +-- Extend the env with bindings for the tyvars, taken from +-- the kind of the tycon/class. Give it to the thing inside, and +-- check the result kind matches +kcLookupKind :: Name -> TcM Kind +kcLookupKind nm + = do { tc_ty_thing <- tcLookup nm + ; case tc_ty_thing of + AThing k -> return k + AGlobal (ATyCon tc) -> return (tyConKind tc) + _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) } + +kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a +-- Used for the type varaibles of a type or class decl, +-- when doing the initial kind-check. +kcTyClTyVars name hs_tvs thing_inside + = bindScopedKindVars hs_tvs $ + do { tc_kind <- kcLookupKind name + ; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind + -- There should be enough arrows, because + -- getInitialKinds used the tcdTyVars + ; name_ks <- zipWithM kc_tv hs_tvs arg_ks + ; tcExtendKindEnv name_ks (thing_inside res_k) } + where + kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) + kc_tv (L _ (UserTyVar n _)) exp_k + = do { check_in_scope n exp_k + ; return (n, exp_k) } + kc_tv (L _ (KindedTyVar n (HsBSig hs_k _) _)) exp_k + = do { k <- tcLHsKind hs_k + ; _ <- unifyKind k exp_k + ; check_in_scope n exp_k + ; return (n, k) } + + check_in_scope :: Name -> Kind -> TcM () + -- In an associated type decl, the type variable may already + -- be in scope; in that case we want to make sure it matches + -- any signature etc here + check_in_scope n exp_k + = do { mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Nothing -> return () + Just (AThing k) -> discardResult (unifyKind k exp_k) + Just thing -> pprPanic "check_in_scope" (ppr thing) } + +----------------------- tcTyClTyVars :: Name -> [LHsTyVarBndr Name] -- LHS of the type or class decl -> ([TyVar] -> Kind -> TcM a) -> TcM a --- tcTyClTyVars T [a,b] calls thing_inside with --- [k1,k2,a,b] (k2 -> *) where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * +-- Used for the type variables of a type or class decl, +-- on the second pass when constructing the final result +-- (tcTyClTyVars T [a,b] thing_inside) +-- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> * +-- calls thing_inside with arguments +-- [k1,k2,a,b] (k2 -> *) +-- having also extended the type environment with bindings +-- for k1,k2,a,b -- -- No need to freshen the k's because they are just skolem -- constants here, and we are at top level anyway. tcTyClTyVars tycon tyvars thing_inside = do { thing <- tcLookup tycon - ; let { kind = - case thing of - AThing kind -> kind - _ -> panic "tcTyClTyVars" + ; let { kind = case thing of + AThing kind -> kind + _ -> panic "tcTyClTyVars" -- We only call tcTyClTyVars during typechecking in -- TcTyClDecls, where the local env is extended with -- the generalized_env (mapping Names to AThings). @@ -957,38 +976,6 @@ tcTyClTyVars tycon tyvars thing_inside ; all_vs = kvs ++ tvs } ; tcExtendTyVarEnv all_vs (thing_inside all_vs res) } --- Used when generalizing binders and type family patterns --- It takes a kind from the type checker (like `k0 -> *`), and returns the --- final, kind-generalized kind (`forall k::BOX. k -> *`) -kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind]) --- INVARIANT: the returned kinds are zonked, and --- mention the returned kind variables -kindGeneralizeKinds kinds - = do { -- Quantify over kind variables free in - -- the kinds, and *not* in the environment - ; zonked_kinds <- mapM zonkTcKind kinds - ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; let kvs_to_quantify = tyVarsOfTypes zonked_kinds - `minusVarSet` gbl_tvs - - ; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify) - zonkQuantifiedTyVars kvs_to_quantify - - -- Zonk the kinds again, to pick up either the kind - -- variables we quantify over, or *, depending on whether - -- zonkQuantifiedTyVars decided to generalise (which in - -- turn depends on PolyKinds) - ; final_kinds <- mapM zonkTcKind zonked_kinds - - ; traceTc "generalizeKind" ( ppr kinds <+> ppr kvs_to_quantify - <+> ppr kvs <+> ppr final_kinds) - ; return (kvs, final_kinds) } - -kindGeneralizeKind :: TcKind -> TcM ( [KindVar] -- these were flexi kind vars - , Kind ) -- this is the old kind where flexis got zonked -kindGeneralizeKind kind = do - (kvs, [kind']) <- kindGeneralizeKinds [kind] - return (kvs, kind') ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] @@ -1082,38 +1069,33 @@ Historical note: \begin{code} tcHsPatSigType :: UserTypeCtxt - -> LHsType Name -- The type signature - -> TcM ([TyVar], -- Newly in-scope type variables - Type) -- The signature + -> HsBndrSig (LHsType Name) -- The type signature + -> TcM ([TyVar], -- Newly in-scope type variables + Type) -- The signature -- Used for type-checking type signatures in -- (a) patterns e.g f (x::Int) = e -- (b) result signatures e.g. g x :: Int = e -- (c) RULE forall bndrs e.g. forall (x::Int). f x = x -tcHsPatSigType ctxt hs_ty +tcHsPatSigType ctxt (HsBSig hs_ty sig_tvs) = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ - do { -- Find the type variables that are mentioned in the type - -- but not already in scope. These are the ones that - -- should be bound by the pattern signature - in_scope <- getInLocalScope - ; let span = getLoc hs_ty - sig_tvs = userHsTyVarBndrs $ map (L span) $ - filterOut in_scope $ - nameSetToList (extractHsTyVars hs_ty) - - ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty + do { let new_tv name = do { kind <- newMetaKindVar + ; return (mkTyVar name kind) } + ; tvs <- mapM new_tv sig_tvs + ; sig_ty <- tcExtendTyVarEnv tvs $ + tcHsLiftedType hs_ty + ; sig_ty <- zonkTcType sig_ty ; checkValidType ctxt sig_ty - ; return (tyvars, sig_ty) - } + ; return (tvs, sig_ty) } tcPatSig :: UserTypeCtxt - -> LHsType Name + -> HsBndrSig (LHsType Name) -> TcSigmaType - -> TcM (TcType, -- The type to use for "inside" the signature - [(Name, TcType)], -- The new bit of type environment, binding - -- the scoped type variables - HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty + -> TcM (TcType, -- The type to use for "inside" the signature + [(Name, TcTyVar)], -- The new bit of type environment, binding + -- the scoped type variables + HsWrapper) -- Coercion due to unification with actual ty + -- Of shape: res_ty ~ sig_ty tcPatSig ctxt sig res_ty = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig -- sig_tvs are the type variables free in 'sig', @@ -1124,17 +1106,16 @@ tcPatSig ctxt sig res_ty -- Just do the subsumption check and return wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - } else do { + } else do -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables - -- The renamer fails with a name-out-of-scope error - -- if a pattern binding tries to bind a type variable, - -- So we just have an ASSERT here - ; let in_pat_bind = case ctxt of + -- It is more convenient to make the test here + -- than in the renamer + { let in_pat_bind = case ctxt of BindPatSigCtxt -> True _ -> False - ; ASSERT( not in_pat_bind || null sig_tvs ) return () + ; when in_pat_bind (addErr (patBindSigErr sig_tvs)) -- Check that all newly-in-scope tyvars are in fact -- constrained by the pattern. This catches tiresome @@ -1147,31 +1128,39 @@ tcPatSig ctxt sig res_ty ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs - ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty - sig_tv_tys' = mkTyVarTys sig_tvs' + ; (subst, sig_tvs') <- tcInstSigTyVars sig_tvs + ; let sig_ty' = substTy subst sig_ty ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' -- Check that each is bound to a distinct type variable, -- and one that is not already in scope ; binds_in_scope <- getScopedTyVarBinds - ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' + ; let tv_binds :: [(Name,TcTyVar)] + tv_binds = map tyVarName sig_tvs `zip` sig_tvs' ; check binds_in_scope tv_binds -- Phew! ; return (sig_ty', tv_binds, wrap) } } where - check _ [] = return () - check in_scope ((n,ty):rest) = do { check_one in_scope n ty - ; check ((n,ty):in_scope) rest } - - check_one in_scope n ty - = checkTc (null dups) (dupInScope n (head dups) ty) + check :: [(Name,TcTyVar)] -> [(Name, TcTyVar)] -> TcM () + check _ [] = return () + check in_scope ((n,tv):rest) = do { check_one in_scope n tv + ; check ((n,tv):in_scope) rest } + + check_one :: [(Name,TcTyVar)] -> Name -> TcTyVar -> TcM () + check_one in_scope n tv + = checkTc (null dups) (dupInScope n (head dups) tv) -- Must not bind to the same type variable -- as some other in-scope type variable where - dups = [n' | (n',ty') <- in_scope, eqType ty' ty] + dups = [n' | (n',tv') <- in_scope, tv' == tv] + +patBindSigErr :: [TyVar] -> SDoc +patBindSigErr sig_tvs + = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs + <+> pprQuotedList sig_tvs) + 2 (ptext (sLit "in a pattern binding signature")) \end{code} @@ -1207,13 +1196,13 @@ expArgKind exp kind arg_no = EK kind (ptext (sLit "The") <+> speakNth arg_no <+> ptext (sLit "argument of") <+> exp <+> ptext (sLit "should have")) -unifyKinds :: SDoc -> [(LHsType Name, TcKind)] -> TcM TcKind -unifyKinds fun act_kinds = do - kind <- newMetaKindVar - let checkArgs (arg_no, (ty, act_kind)) = - checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) - mapM_ checkArgs (zip [1..] act_kinds) - return kind +unifyKinds :: SDoc -> [(TcType, TcKind)] -> TcM TcKind +unifyKinds fun act_kinds + = do { kind <- newMetaKindVar + ; let check (arg_no, (ty, act_kind)) + = checkExpectedKind ty act_kind (expArgKind (quotes fun) kind arg_no) + ; mapM_ check (zip [1..] act_kinds) + ; return kind } checkExpectedKind :: Outputable a => a -> TcKind -> ExpKind -> TcM () -- A fancy wrapper for 'unifyKind', which tries @@ -1283,65 +1272,59 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do %* * %************************************************************************ -scDsLHsKind converts a user-written kind to an internal, sort-checked kind. +tcLHsKind converts a user-written kind to an internal, sort-checked kind. It does sort checking and desugaring at the same time, in one single pass. It fails when the kinds are not well-formed (eg. data A :: * Int), or if there are non-promotable or non-fully applied kinds. \begin{code} -scDsLHsKind :: LHsKind Name -> TcM Kind -scDsLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ - sc_ds_lhs_kind k - -scDsLHsMaybeKind :: Maybe (LHsKind Name) -> TcM (Maybe Kind) -scDsLHsMaybeKind Nothing = return Nothing -scDsLHsMaybeKind (Just k) = do k' <- scDsLHsKind k - return (Just k') +tcLHsKind :: LHsKind Name -> TcM Kind +tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $ + tc_lhs_kind k -sc_ds_lhs_kind :: LHsKind Name -> TcM Kind -sc_ds_lhs_kind (L span ki) = setSrcSpan span (sc_ds_hs_kind ki) +tc_lhs_kind :: LHsKind Name -> TcM Kind +tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki) -- The main worker -sc_ds_hs_kind :: HsKind Name -> TcM Kind -sc_ds_hs_kind k@(HsTyVar _) = sc_ds_app k [] -sc_ds_hs_kind k@(HsAppTy _ _) = sc_ds_app k [] +tc_hs_kind :: HsKind Name -> TcM Kind +tc_hs_kind k@(HsTyVar _) = tc_app k [] +tc_hs_kind k@(HsAppTy _ _) = tc_app k [] -sc_ds_hs_kind (HsParTy ki) = sc_ds_lhs_kind ki +tc_hs_kind (HsParTy ki) = tc_lhs_kind ki -sc_ds_hs_kind (HsFunTy ki1 ki2) = - do kappa_ki1 <- sc_ds_lhs_kind ki1 - kappa_ki2 <- sc_ds_lhs_kind ki2 +tc_hs_kind (HsFunTy ki1 ki2) = + do kappa_ki1 <- tc_lhs_kind ki1 + kappa_ki2 <- tc_lhs_kind ki2 return (mkArrowKind kappa_ki1 kappa_ki2) -sc_ds_hs_kind (HsListTy ki) = - do kappa <- sc_ds_lhs_kind ki +tc_hs_kind (HsListTy ki) = + do kappa <- tc_lhs_kind ki checkWiredInTyCon listTyCon return $ mkPromotedListTy kappa -sc_ds_hs_kind (HsTupleTy _ kis) = - do kappas <- mapM sc_ds_lhs_kind kis +tc_hs_kind (HsTupleTy _ kis) = + do kappas <- mapM tc_lhs_kind kis checkWiredInTyCon tycon return $ mkTyConApp tycon kappas where tycon = promotedTupleTyCon BoxedTuple (length kis) -- Argument not kind-shaped -sc_ds_hs_kind k = panic ("sc_ds_hs_kind: " ++ showPpr k) +tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k) -- Special case for kind application -sc_ds_app :: HsKind Name -> [LHsKind Name] -> TcM Kind -sc_ds_app (HsAppTy ki1 ki2) kis = sc_ds_app (unLoc ki1) (ki2:kis) -sc_ds_app (HsTyVar tc) kis = - do arg_kis <- mapM sc_ds_lhs_kind kis - sc_ds_var_app tc arg_kis -sc_ds_app ki _ = failWithTc (quotes (ppr ki) <+> +tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind +tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis) +tc_app (HsTyVar tc) kis = + do arg_kis <- mapM tc_lhs_kind kis + tc_var_app tc arg_kis +tc_app ki _ = failWithTc (quotes (ppr ki) <+> ptext (sLit "is not a kind constructor")) --- IA0_TODO: With explicit kind polymorphism I might need to add ATyVar -sc_ds_var_app :: Name -> [Kind] -> TcM Kind +tc_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 +tc_var_app name arg_kis | name == liftedTypeKindTyConName || name == constraintKindTyConName = do { unless (null arg_kis) @@ -1349,10 +1332,10 @@ sc_ds_var_app name arg_kis ; thing <- tcLookup name ; case thing of AGlobal (ATyCon tc) -> return (mkTyConApp tc []) - _ -> panic "sc_ds_var_app 1" } + _ -> panic "tc_var_app 1" } -- General case -sc_ds_var_app name arg_kis = do +tc_var_app name arg_kis = do (_errs, mb_thing) <- tryTc (tcLookup name) case mb_thing of Just (AGlobal (ATyCon tc)) @@ -1365,11 +1348,16 @@ sc_ds_var_app name arg_kis = do Just _ -> err tc "is not fully applied" Nothing -> err tc "is not promotable" + -- A lexically scoped kind variable + Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) + -- 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 ) + Nothing -> -- ASSERT2 ( isTyConName name, ppr name ) + do env <- getLclEnv + traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env)) failWithTc (ptext (sLit "Promoted kind") <+> quotes (ppr name) <+> ptext (sLit "used in a mutually recursive group")) @@ -1406,7 +1394,7 @@ badPatSigTvs sig_ty bad_tvs , ptext (sLit "To fix this, expand the type synonym") , ptext (sLit "[Note: I hope to lift this restriction in due course]") ] -dupInScope :: Name -> Name -> Type -> SDoc +dupInScope :: Name -> Name -> TcTyVar -> SDoc dupInScope n n' _ = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n')) 2 (vcat [ptext (sLit "are bound to the same type (variable)"), diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 89a034ba18..229fed36b6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -392,6 +392,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- try the deriving stuff, because that may give -- more errors still + ; traceTc "tcDeriving" empty ; (gbl_env, deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls deriv_decls @@ -426,7 +427,8 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ tcExtendGlobalEnvImplicit things $ - do { tcg_env <- tcAddImplicits things + do { traceTc "addFamInsts" (pprFamInsts fam_insts) + ; tcg_env <- tcAddImplicits things ; setGblEnv tcg_env thing_inside } where axioms = map famInstAxiom fam_insts @@ -558,7 +560,8 @@ tcFamInstDecl1 fam_tc (decl@TySynonym {}) ; 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 +tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCType = cType + , tcdCtxt = ctxt , tcdTyVars = tvs, tcdTyPats = Just pats , tcdCons = cons}) = do { -- Check that the family declaration is for the right kind @@ -566,8 +569,8 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats fam_tc tvs pats (\_always_star -> kcDataDecl decl) $ - \tvs' pats' resultKind -> do + ; tcFamTyPats fam_tc tvs pats (kcDataDecl decl) $ + \tvs' pats' res_kind -> do -- Check that left-hand side contains no type family applications -- (vanilla synonyms are fine, though, and we checked for @@ -575,9 +578,9 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt { mapM_ checkTyFamFreeness pats' -- Result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resultKind) $ tooFewParmsErr (tyConArity fam_tc) + ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) - ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt + ; stupid_theta <- tcHsContext ctxt ; dataDeclChecks (tcdName decl) new_or_data stupid_theta cons -- Construct representation tycon @@ -595,7 +598,7 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data, tcdCtxt = ctxt 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 + rep_tc = buildAlgTyCon rep_tc_name tvs' cType 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 @@ -793,34 +796,59 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) loc = getSrcSpan dfun_id ------------------------------ -checkInstSig :: Class -> [TcType] -> LSig Name -> TcM () --- Check that any type signatures have exactly the right type -checkInstSig clas inst_tys (L loc (TypeSig names@(L _ name1:_) hs_ty)) - = setSrcSpan loc $ - do { inst_sigs <- xoptM Opt_InstanceSigs - ; if inst_sigs then - do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty - ; mapM_ (check sigma_ty) names } - else - addErrTc (misplacedInstSig names hs_ty) } +---------------------- +mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] + -> [TcType] -> Id -> TcM (TcId, TcSigInfo) +mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id + = do { uniq <- newUnique + ; loc <- getSrcSpanM + ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name + ; local_meth_name <- newLocalName sel_name + -- Base the local_meth_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + ; local_meth_sig <- case lookupHsSig sig_fn sel_name of + Just hs_ty -- There is a signature in the instance declaration + -> do { sig_ty <- check_inst_sig hs_ty + ; instTcTySig hs_ty sig_ty local_meth_name } + + Nothing -- No type signature + -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) + -- Absent a type sig, there are no new scoped type variables here + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = <rhs> } + -- In <rhs>, 'c' is scope but 'b' is not! + + ; let meth_id = mkLocalId meth_name meth_ty + ; return (meth_id, local_meth_sig) } where - check sigma_ty (L _ n) - = do { sel_id <- tcLookupId n - ; let meth_ty = instantiateMethod clas sel_id inst_tys - ; checkTc (sigma_ty `eqType` meth_ty) - (badInstSigErr n meth_ty) } - -checkInstSig _ _ _ = return () + sel_name = idName sel_id + local_meth_ty = instantiateMethod clas sel_id inst_tys + meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty + + -- Check that any type signatures have exactly the right type + check_inst_sig hs_ty@(L loc _) + = setSrcSpan loc $ + do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty + ; inst_sigs <- xoptM Opt_InstanceSigs + ; if inst_sigs then + checkTc (sig_ty `eqType` local_meth_ty) + (badInstSigErr sel_name sig_ty) + else + addErrTc (misplacedInstSig sel_name hs_ty) + ; return sig_ty } badInstSigErr :: Name -> Type -> SDoc badInstSigErr meth ty = hang (ptext (sLit "Method signature does not match class; it should be")) 2 (pprPrefixName meth <+> dcolon <+> ppr ty) -misplacedInstSig :: [Located Name] -> LHsType Name -> SDoc -misplacedInstSig names hs_ty +misplacedInstSig :: Name -> LHsType Name -> SDoc +misplacedInstSig name hs_ty = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:")) - 2 (hang (hsep $ punctuate comma (map (pprPrefixName . unLoc) names)) + 2 (hang (pprPrefixName name) 2 (dcolon <+> ppr hs_ty)) , ptext (sLit "(Use -XInstanceSigs to allow this)") ] @@ -968,46 +996,47 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (spec_inst_prags, prag_fn) op_items (VanillaInst binds sigs standalone_deriv) - = do { mapM_ (checkInstSig clas inst_tys) sigs - ; mapAndUnzipM tc_item op_items } + = do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds) + ; let hs_sig_fn = mkHsSigFun sigs + ; mapAndUnzipM (tc_item hs_sig_fn) op_items } where ---------------------- - tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id) - tc_item (sel_id, dm_info) + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) + tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of - Just user_bind -> tc_body sel_id standalone_deriv user_bind + Just user_bind -> tc_body sig_fn sel_id standalone_deriv user_bind Nothing -> traceTc "tc_def" (ppr sel_id) >> - tc_default sel_id dm_info + tc_default sig_fn sel_id dm_info ---------------------- - tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) - tc_body sel_id generated_code rn_bind + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) + tc_body sig_fn sel_id generated_code rn_bind = add_meth_ctxt sel_id generated_code rn_bind $ - do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id - ; let sel_name = idName sel_id - prags = prag_fn (idName sel_id) + do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) + ; (meth_id, local_meth_sig) <- setSrcSpan (getLoc rn_bind) $ + mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id + ; let prags = prag_fn (idName sel_id) ; meth_id1 <- addInlinePrags meth_id prags ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol tyvars dfun_ev_vars - meth_id1 local_meth_id - (mk_meth_sig_fn sel_name) + meth_id1 local_meth_sig (mk_meth_spec_prags meth_id1 spec_prags) rn_bind ; return (meth_id1, bind) } ---------------------- - tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) - tc_default sel_id (GenDefMeth dm_name) + tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name - ; tc_body sel_id False {- Not generated code? -} meth_bind } + ; tc_body sig_fn sel_id False {- Not generated code? -} meth_bind } - tc_default sel_id NoDefMeth -- No default method at all + tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) ; warnMissingMethodOrAT "method" (idName sel_id) - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; return (meth_id, mkVarBind meth_id $ mkLHsWrap lam_wrapper error_rhs) } @@ -1019,7 +1048,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - tc_default sel_id (DefMeth dm_name) -- A polymorphic default method + tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method = do { -- Build the typechecked version directly, -- without calling typecheck_method; -- see Note [Default methods in instances] @@ -1032,13 +1061,14 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; let self_ev_bind = EvBind self_dict (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars) - ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id + local_meth_id = sig_id local_meth_sig meth_bind = mkVarBind local_meth_id (L loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag -- Copy the inline pragma (if any) from the default @@ -1080,19 +1110,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = [ L loc (SpecPrag meth_id wrap inl) | L loc (SpecPrag _ wrap inl) <- spec_inst_prags] - loc = getSrcSpan dfun_id - sig_fn = mkSigFun sigs - mk_meth_sig_fn sel_name _meth_name - = case sig_fn sel_name of - Nothing -> Just ([],loc) - Just r -> Just r - -- The orElse 'Just' says "yes, in effect there's always a type sig" - -- But there are no scoped type variables from local_method_id - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! + loc = getSrcSpan dfun_id -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -1143,14 +1161,16 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- co : [p] ~ T p co = mkTcSymCo (mkTcInstCos coi (mkTyVarTys tyvars)) + sig_fn = emptyHsSigs ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) tc_item (rep_ev_binds, rep_d) (sel_id, _) - = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars - inst_tys sel_id + = do { (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars + inst_tys sel_id - ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id + ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id + local_meth_id = sig_id local_meth_sig meth_bind = mkVarBind local_meth_id (L loc meth_rhs) export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id , abe_mono = local_meth_id, abe_prags = noSpecPrags } @@ -1174,23 +1194,6 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys `orElse` pprPanic "tcInstanceMethods" (ppr sel_id) ---------------------- -mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId) -mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - = do { uniq <- newUnique - ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name - ; local_meth_name <- newLocalName sel_name - -- Base the local_meth_name on the selector name, becuase - -- type errors from tcInstanceMethodBody come from here - - ; let meth_id = mkLocalId meth_name meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty - ; return (meth_id, local_meth_id) } - where - local_meth_ty = instantiateMethod clas sel_id inst_tys - meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty - sel_name = idName sel_id - ----------------------- wrapId :: HsWrapper -> id -> HsExpr id wrapId wrapper id = mkHsWrap wrapper (HsVar id) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 7c5957f7fb..c084f7d676 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -535,7 +535,7 @@ trySpontaneousEqTwoWay :: SubGoalDepth -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here trySpontaneousEqTwoWay d eqv gw tv1 tv2 - = do { let k1_sub_k2 = k1 `isSubKind` k2 + = do { let k1_sub_k2 = k1 `tcIsSubKind` k2 ; if k1_sub_k2 && nicer_to_update_tv2 then solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1) else solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } @@ -543,7 +543,6 @@ trySpontaneousEqTwoWay d eqv gw tv1 tv2 k1 = tyVarKind tv1 k2 = tyVarKind tv2 nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2) - \end{code} Note [Kind errors] @@ -635,17 +634,22 @@ solveWithIdentity d eqv wd tv xi text "Right Kind is : " <+> ppr (typeKind xi) ] - ; setWantedTyBind tv xi - ; let refl_xi = mkTcReflCo xi + ; let xi' = defaultKind xi + -- We only instantiate kind unification variables + -- with simple kinds like *, not OpenKind or ArgKind + -- cf TcUnify.uUnboundKVar + + ; setWantedTyBind tv xi' + ; let refl_xi = mkTcReflCo xi' ; let solved_fl = mkSolvedFlavor wd UnkSkol (EvCoercion refl_xi) - ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi + ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi' refl_xi ; when (isWanted wd) $ do { _ <- setEqBind eqv refl_xi wd; return () } -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' ; return $ SPSolved (CTyEqCan { cc_id = eqv_given , cc_flavor = solved_fl - , cc_tyvar = tv, cc_rhs = xi, cc_depth = d }) } + , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } \end{code} @@ -1553,7 +1557,7 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl ; return $ SomeTopInt { tir_rule = "Fun/Top (given)" , tir_new_item = ContinueWith workItem } } - Derived {} -> do { evc <- newEvVar fl (mkEqPred (xi, rhs_ty)) + Derived {} -> do { evc <- newEvVar fl (mkTcEqPred xi rhs_ty) ; let eqv' = evc_the_evvar evc ; when (isNewEvVar evc) $ (let ct = CNonCanonical { cc_id = eqv' diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 48ad6e379d..82c465c6e0 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -24,7 +24,7 @@ module TcMType ( newFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newMetaKindVar, newMetaKindVars, + newMetaKindVar, newMetaKindVars, mkKindSigVar, mkTcTyVarName, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, @@ -60,8 +60,8 @@ module TcMType ( -------------------------------- -- Zonking zonkType, zonkKind, zonkTcPredType, - zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, + skolemiseSigTv, skolemiseUnboundMetaTyVar, + zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, @@ -70,8 +70,6 @@ module TcMType ( zonkTcTypeAndSubst, tcGetGlobalTyVars, - - compatKindTcM, isSubKindTcM ) where #include "HsVersions.h" @@ -118,12 +116,16 @@ import Data.List ( (\\), partition, mapAccumL ) \begin{code} newMetaKindVar :: TcM TcKind -newMetaKindVar = do { uniq <- newUnique - ; ref <- newMutVar Flexi - ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } +newMetaKindVar = do { uniq <- newUnique + ; ref <- newMutVar Flexi + ; return (mkTyVarTy (mkMetaKindVar uniq ref)) } newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) + +mkKindSigVar :: Name -> KindVar +-- Use the specified name; don't clone it +mkKindSigVar n = mkTcTyVar n superKind (SkolemTv False) \end{code} @@ -153,7 +155,7 @@ newEvVar ty = do { name <- newName (predTypeOccName ty) newEq :: TcType -> TcType -> TcM EvVar newEq ty1 ty2 = do { name <- newName (mkVarOccFS (fsLit "cobox")) - ; return (mkLocalId name (mkEqPred (ty1, ty2))) } + ; return (mkLocalId name (mkTcEqPred ty1 ty2)) } newIP :: IPName Name -> TcType -> TcM IpId newIP ip ty @@ -182,7 +184,7 @@ predTypeOccName ty = case classifyPredType ty of %************************************************************************ \begin{code} -tcInstType :: ([TyVar] -> TcM [TcTyVar]) -- How to instantiate the type variables +tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar])) -- How to instantiate the type variables -> TcType -- Type to instantiate -> TcM ([TcTyVar], TcThetaType, TcType) -- Result -- (type vars (excl coercion vars), preds (incl equalities), rho) @@ -194,14 +196,8 @@ tcInstType inst_tyvars ty in return ([], theta, tau) - (tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars - - ; let tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars') - -- Either the tyvars are freshly made, by inst_tyvars, - -- or any nested foralls have different binders. - -- Either way, zipTopTvSubst is ok - - ; let (theta, tau) = tcSplitPhiTy (substTy tenv rho) + (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTy subst rho) ; return (tyvars', theta, tau) } tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) @@ -210,12 +206,12 @@ tcSkolDFunType :: Type -> TcM ([TcTyVar], TcThetaType, TcType) -- be in the type environment: it is lexically scoped. tcSkolDFunType ty = tcInstType (\tvs -> return (tcSuperSkolTyVars tvs)) ty -tcSuperSkolTyVars :: [TyVar] -> [TcTyVar] +tcSuperSkolTyVars :: [TyVar] -> (TvSubst, [TcTyVar]) -- Make skolem constants, but do *not* give them new names, as above -- Moreover, make them "super skolems"; see comments with superSkolemTv -- see Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered (kind vars first) -tcSuperSkolTyVars = snd . mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) +tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar (mkTopTvSubst []) tcSuperSkolTyVar :: TvSubst -> TyVar -> (TvSubst, TcTyVar) tcSuperSkolTyVar subst tv @@ -241,14 +237,11 @@ tcInstSkolTyVar overlappable subst tyvar occ = nameOccName old_name kind = substTy subst (tyVarKind tyvar) -tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) --- Precondition: tyvars should be ordered (kind vars first) --- see Note [Kind substitution when instantiating] -tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) - -- Wrappers -tcInstSkolTyVars, tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] -tcInstSkolTyVars = fmap snd . tcInstSkolTyVars' False (mkTopTvSubst []) +tcInstSkolTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) +tcInstSkolTyVars = tcInstSkolTyVarsX (mkTopTvSubst []) + +tcInstSuperSkolTyVars :: [TyVar] -> TcM [TcTyVar] tcInstSuperSkolTyVars = fmap snd . tcInstSkolTyVars' True (mkTopTvSubst []) tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX @@ -256,17 +249,24 @@ tcInstSkolTyVarsX, tcInstSuperSkolTyVarsX tcInstSkolTyVarsX subst = tcInstSkolTyVars' False subst tcInstSuperSkolTyVarsX subst = tcInstSkolTyVars' True subst +tcInstSkolTyVars' :: Bool -> TvSubst -> [TyVar] -> TcM (TvSubst, [TcTyVar]) +-- Precondition: tyvars should be ordered (kind vars first) +-- see Note [Kind substitution when instantiating] +tcInstSkolTyVars' isSuperSkol = mapAccumLM (tcInstSkolTyVar isSuperSkol) + tcInstSkolType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type with fresh skolem constants -- Binding location comes from the monad tcInstSkolType ty = tcInstType tcInstSkolTyVars ty -tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] +tcInstSigTyVars :: [TyVar] -> TcM (TvSubst, [TcTyVar]) -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -- Precondition: tyvars should be ordered (kind vars first) -- see Note [Kind substitution when instantiating] -tcInstSigTyVars = fmap snd . mapAccumLM tcInstSigTyVar (mkTopTvSubst []) +tcInstSigTyVars = mapAccumLM tcInstSigTyVar (mkTopTvSubst []) + -- The tyvars are freshly made, by tcInstSigTyVar + -- So mkTopTvSubst [] is ok tcInstSigTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) tcInstSigTyVar subst tv @@ -389,7 +389,7 @@ writeMetaTyVarRef tyvar ref ty ; writeMutVar ref (Indirect ty) ; when ( not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables - && not (zonked_ty_kind `isSubKind` zonked_tv_kind)) + && not (zonked_ty_kind `tcIsSubKind` zonked_tv_kind)) $ WARN( True, hang (text "Ill-kinded update to meta tyvar") 2 ( ppr tyvar <+> text "::" <+> ppr tv_kind <+> text ":=" @@ -419,22 +419,26 @@ newFlexiTyVarTy kind = do newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVars :: [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables +-- Note that this works for a sequence of kind and type +-- variables. Eg [ (k:BOX), (a:k->k) ] +-- Gives [ (k7:BOX), (a8:k7->k7) ] tcInstTyVars tyvars = tcInstTyVarsX emptyTvSubst tyvars -- emptyTvSubst has an empty in-scope set, but that's fine here -- Since the tyvars are freshly made, they cannot possibly be -- captured by any existing for-alls. -tcInstTyVarsX :: TvSubst -> [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVarsX :: TvSubst -> [TKVar] -> TcM ([TcTyVar], [TcType], TvSubst) +-- The "X" part is because of extending the substitution tcInstTyVarsX subst tyvars = - do { (subst', tyvars') <- mapAccumLM tcInstTyVar subst tyvars + do { (subst', tyvars') <- mapAccumLM tcInstTyVarX subst tyvars ; return (tyvars', mkTyVarTys tyvars', subst') } -tcInstTyVar :: TvSubst -> TyVar -> TcM (TvSubst, TcTyVar) +tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. -tcInstTyVar subst tyvar +tcInstTyVarX subst tyvar = do { uniq <- newMetaUnique ; ref <- newMutVar Flexi ; let name = mkSystemName uniq (getOccName tyvar) @@ -480,44 +484,31 @@ tcGetGlobalTyVars :: TcM TcTyVarSet tcGetGlobalTyVars = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv ; gbl_tvs <- readMutVar gtv_var - ; gbl_tvs' <- zonkTcTyVarsAndFV gbl_tvs + ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs ; writeMutVar gtv_var gbl_tvs' ; return gbl_tvs' } + where \end{code} ----------------- Type variables \begin{code} +zonkTyVar :: TyVar -> TcM TcType +-- Works on TyVars and TcTyVars +zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv + | otherwise = return (mkTyVarTy tv) + -- Hackily, when typechecking type and class decls + -- we have TyVars in scopeadded (only) in + -- TcHsType.tcTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet +zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) + zonkTcTyVars :: [TcTyVar] -> TcM [TcType] zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars -zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet -zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars) - ----------------- Types -zonkTcTypeCarefully :: TcType -> TcM TcType --- Do not zonk type variables free in the environment -zonkTcTypeCarefully ty = zonkTcType ty -- I think this function is out of date - -{- - = do { env_tvs <- tcGetGlobalTyVars - ; zonkType (zonk_tv env_tvs) ty } - where - zonk_tv env_tvs tv - | tv `elemVarSet` env_tvs - = return (TyVarTy tv) - | otherwise - = ASSERT( isTcTyVar tv ) - case tcTyVarDetails tv of - SkolemTv {} -> return (TyVarTy tv) - RuntimeUnk {} -> return (TyVarTy tv) - FlatSkol ty -> zonkType (zonk_tv env_tvs) ty - MetaTv _ ref -> do { cts <- readMutVar ref - ; case cts of - Flexi -> return (TyVarTy tv) - Indirect ty -> zonkType (zonk_tv env_tvs) ty } --} - zonkTcType :: TcType -> TcM TcType -- Simply look through all Flexis zonkTcType ty = zonkType zonkTcTyVar ty @@ -579,15 +570,14 @@ zonkTcPredType = zonkTcType defaultKindVarToStar :: TcTyVar -> TcM Kind -- We have a meta-kind: unify it with '*' defaultKindVarToStar kv - = do { ASSERT ( isKiVar kv && isMetaTyVar kv ) + = do { ASSERT ( isKindVar kv && isMetaTyVar kv ) writeMetaTyVar kv liftedTypeKind ; return liftedTypeKind } -zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar] --- Precondition: a kind variable occurs before a type --- variable mentioning it in its kind +zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar] +-- A kind variable k may occur *after* a tyvar mentioning k in its kind zonkQuantifiedTyVars tyvars - = do { let (kvs, tvs) = partitionKiTyVars (varSetElems tyvars) + = do { let (kvs, tvs) = partition isKindVar tyvars ; poly_kinds <- xoptM Opt_PolyKinds ; if poly_kinds then mapM zonkQuantifiedTyVar (kvs ++ tvs) @@ -655,6 +645,17 @@ skolemiseUnboundMetaTyVar tv details ; writeMetaTyVar tv (mkTyVarTy final_tv) ; return final_tv } + +skolemiseSigTv :: TcTyVar -> TcM TcTyVar +-- In TcBinds we create SigTvs for type signatures +-- but for singleton groups we want them to really be skolems +-- which do not unify with each other +skolemiseSigTv tv + = ASSERT2( isSigTyVar tv, ppr tv ) + do { writeMetaTyVarRef tv (metaTvRef tv) (mkTyVarTy skol_tv) + ; return skol_tv } + where + skol_tv = setTcTyVarDetails tv (SkolemTv False) \end{code} \begin{code} @@ -820,12 +821,12 @@ zonkType zonk_tc_tyvar ty -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = TyVarTy <$> updateTyVarKindM zonkTcKind tyvar + | otherwise = TyVarTy <$> updateTyVarKindM go tyvar -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- updateTyVarKindM zonkTcKind tyvar + tyvar' <- updateTyVarKindM go tyvar return (ForAllTy tyvar' ty') \end{code} @@ -838,19 +839,6 @@ zonkType zonk_tc_tyvar ty %************************************************************************ \begin{code} -compatKindTcM :: Kind -> Kind -> TcM Bool -compatKindTcM k1 k2 - = do { k1' <- zonkTcKind k1 - ; k2' <- zonkTcKind k2 - ; return $ k1' `isSubKind` k2' || k2' `isSubKind` k1' } - -isSubKindTcM :: Kind -> Kind -> TcM Bool -isSubKindTcM k1 k2 - = do { k1' <- zonkTcKind k1 - ; k2' <- zonkTcKind k2 - ; return $ k1' `isSubKind` k2' } - -------------- zonkTcKind :: TcKind -> TcM TcKind zonkTcKind k = zonkTcType k \end{code} @@ -899,71 +887,74 @@ expectedKindInCtxt GhciCtxt = Nothing expectedKindInCtxt ResSigCtxt = Just openTypeKind expectedKindInCtxt ExprSigCtxt = Just openTypeKind expectedKindInCtxt (ForSigCtxt _) = Just liftedTypeKind +expectedKindInCtxt InstDeclCtxt = Just constraintKind +expectedKindInCtxt SpecInstCtxt = Just constraintKind expectedKindInCtxt _ = Just argTypeKind checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context -checkValidType ctxt ty = do - traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) - unboxed <- xoptM Opt_UnboxedTuples - rank2 <- xoptM Opt_Rank2Types - rankn <- xoptM Opt_RankNTypes - polycomp <- xoptM Opt_PolymorphicComponents - constraintKinds <- xoptM Opt_ConstraintKinds - let - gen_rank n | rankn = ArbitraryRank - | rank2 = Rank 2 - | otherwise = Rank n - rank - = case ctxt of - DefaultDeclCtxt-> MustBeMonoType - ResSigCtxt -> MustBeMonoType - LamPatSigCtxt -> gen_rank 0 - BindPatSigCtxt -> gen_rank 0 - TySynCtxt _ -> gen_rank 0 - - ExprSigCtxt -> gen_rank 1 - FunSigCtxt _ -> gen_rank 1 - InfSigCtxt _ -> ArbitraryRank -- Inferred type - ConArgCtxt _ | polycomp -> gen_rank 2 - -- We are given the type of the entire - -- constructor, hence rank 1 - | otherwise -> gen_rank 1 - - ForSigCtxt _ -> gen_rank 1 - SpecInstCtxt -> gen_rank 1 +-- Not used for instance decls; checkValidInstance instead +checkValidType ctxt ty + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) + ; unboxed <- xoptM Opt_UnboxedTuples + ; rank2 <- xoptM Opt_Rank2Types + ; rankn <- xoptM Opt_RankNTypes + ; polycomp <- xoptM Opt_PolymorphicComponents + ; constraintKinds <- xoptM Opt_ConstraintKinds + ; let gen_rank n | rankn = ArbitraryRank + | rank2 = Rank 2 + | otherwise = Rank n + rank + = case ctxt of + DefaultDeclCtxt-> MustBeMonoType + ResSigCtxt -> MustBeMonoType + LamPatSigCtxt -> gen_rank 0 + BindPatSigCtxt -> gen_rank 0 + TySynCtxt _ -> gen_rank 0 + + ExprSigCtxt -> gen_rank 1 + FunSigCtxt _ -> gen_rank 1 + InfSigCtxt _ -> ArbitraryRank -- Inferred type + ConArgCtxt _ | polycomp -> gen_rank 2 + -- We are given the type of the entire + -- constructor, hence rank 1 + | otherwise -> gen_rank 1 + + ForSigCtxt _ -> gen_rank 1 + SpecInstCtxt -> gen_rank 1 ThBrackCtxt -> gen_rank 1 - GhciCtxt -> ArbitraryRank + GhciCtxt -> ArbitraryRank _ -> panic "checkValidType" - -- Can't happen; not used for *user* sigs + -- Can't happen; not used for *user* sigs - actual_kind = typeKind ty + actual_kind = typeKind ty - kind_ok = case expectedKindInCtxt ctxt of - Nothing -> True - Just k -> tcIsSubKind actual_kind k + kind_ok = case expectedKindInCtxt ctxt of + Nothing -> True + Just k -> tcIsSubKind actual_kind k - ubx_tup - | not unboxed = UT_NotOk - | otherwise = case ctxt of - TySynCtxt _ -> UT_Ok - ExprSigCtxt -> UT_Ok - ThBrackCtxt -> UT_Ok - GhciCtxt -> UT_Ok - _ -> UT_NotOk + ubx_tup + | not unboxed = UT_NotOk + | otherwise = case ctxt of + TySynCtxt _ -> UT_Ok + ExprSigCtxt -> UT_Ok + ThBrackCtxt -> UT_Ok + GhciCtxt -> UT_Ok + _ -> UT_NotOk -- Check the internal validity of the type itself - check_type rank ubx_tup ty + ; check_type rank ubx_tup ty -- Check that the thing has kind Type, and is lifted if necessary -- Do this second, because we can't usefully take the kind of an -- ill-formed type such as (a~Int) - checkTc kind_ok (kindErr actual_kind) + ; checkTc kind_ok (kindErr actual_kind) -- Check that the thing does not have kind Constraint, -- if -XConstraintKinds isn't enabled - unless constraintKinds - $ checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) + ; unless constraintKinds $ + checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) + } checkValidMonoType :: Type -> TcM () checkValidMonoType ty = check_mono_type MustBeMonoType ty @@ -1216,7 +1207,7 @@ check_pred_ty' dflags _ctxt (EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) - (eqPredTyErr (mkEqPred (ty1, ty2))) + (eqPredTyErr (mkEqPred ty1 ty2)) -- Check the form of the argument types ; checkValidMonoType ty1 @@ -1490,26 +1481,27 @@ We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () -checkValidInstHead ctxt clas tys +checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags -- Check language restrictions; -- but not for SPECIALISE isntance pragmas + ; let ty_args = dropWhile isKind cls_args ; unless spec_inst_prag $ do { checkTc (xopt Opt_TypeSynonymInstances dflags || - all tcInstHeadTyNotSynonym tys) + all tcInstHeadTyNotSynonym ty_args) (instTypeErr pp_pred head_type_synonym_msg) ; checkTc (xopt Opt_FlexibleInstances dflags || - all tcInstHeadTyAppAllTyVars tys) + all tcInstHeadTyAppAllTyVars ty_args) (instTypeErr pp_pred head_type_args_tyvars_msg) ; checkTc (xopt Opt_MultiParamTypeClasses dflags || - isSingleton (dropWhile isKind tys)) -- IA0_NOTE: only count type arguments + isSingleton ty_args) -- Only count type arguments (instTypeErr pp_pred head_one_type_msg) } -- May not contain type family applications - ; mapM_ checkTyFamFreeness tys + ; mapM_ checkTyFamFreeness ty_args - ; mapM_ checkValidMonoType tys + ; mapM_ checkValidMonoType ty_args -- For now, I only allow tau-types (not polytypes) in -- the head of an instance decl. -- E.g. instance C (forall a. a->a) is rejected @@ -1520,7 +1512,7 @@ checkValidInstHead ctxt clas tys where spec_inst_prag = case ctxt of { SpecInstCtxt -> True; _ -> False } - pp_pred = pprClassPred clas tys + pp_pred = pprClassPred clas cls_args head_type_synonym_msg = parens ( text "All instance types must be of the form (T t1 ... tn)" $$ text "where T is not a synonym." $$ @@ -1572,13 +1564,16 @@ validDerivPred tv_set ty = case getClassPredTys_maybe ty of %************************************************************************ \begin{code} -checkValidInstance :: UserTypeCtxt -> LHsType Name -> [TyVar] -> ThetaType - -> Class -> [TcType] -> TcM () -checkValidInstance ctxt hs_type tyvars theta clas inst_tys - = setSrcSpan (getLoc hs_type) $ +checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type + -> TcM ([TyVar], ThetaType, Class, [Type]) +checkValidInstance ctxt hs_type ty + = do { let (tvs, theta, tau) = tcSplitSigmaTy ty + ; case getClassPredTys_maybe tau of { + Nothing -> failWithTc (ptext (sLit "Malformed instance type")) ; + Just (clas,inst_tys) -> do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) ; checkValidTheta ctxt theta - ; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys) + ; checkAmbiguity tvs theta (tyVarsOfTypes inst_tys) -- Check that instance inference will terminate (if we care) -- For Haskell 98 this will already have been done by checkValidTheta, @@ -1590,7 +1585,7 @@ checkValidInstance ctxt hs_type tyvars theta clas inst_tys -- The Coverage Condition ; checkTc (undecidable_ok || checkInstCoverage clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) - } + ; return (tvs, theta, clas, inst_tys) } } } where msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f1f502d967..7b759d100e 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -138,12 +138,11 @@ data TcSigInfo = TcSigInfo { sig_id :: TcId, -- *Polymorphic* binder for this value... - sig_scoped :: [Name], -- Scoped type variables - -- 1-1 correspondence with a prefix of sig_tvs - -- However, may be fewer than sig_tvs; - -- see Note [More instantiated than scoped] - sig_tvs :: [TcTyVar], -- Instantiated type variables - -- See Note [Instantiate sig] + sig_tvs :: [(Maybe Name, TcTyVar)], + -- Instantiated type and kind variables + -- Just n <=> this skolem is lexically in scope with name n + -- See Note [Kind vars in sig_tvs] + -- See Note [More instantiated than scoped] in TcBinds sig_theta :: TcThetaType, -- Instantiated theta @@ -158,6 +157,16 @@ instance Outputable TcSigInfo where = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau \end{code} +Note [Kind vars in sig_tvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With kind polymorphism a signature like + f :: forall f a. f a -> f a +may actuallly give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a +So the sig_tvs will be [k,f,a], but only f,a are scoped. +So the scoped ones are not necessarily the *inital* ones! + + Note [sig_tau may be polymorphic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that "sig_tau" might actually be a polymorphic type, @@ -242,12 +251,14 @@ newNoSigLetBndr (LetGblBndr prags) name ty ---------- addInlinePrags :: TcId -> [LSig Name] -> TcM TcId addInlinePrags poly_id prags - = tc_inl inl_sigs + = do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags) + ; tc_inl inl_sigs } where inl_sigs = filter isInlineLSig prags tc_inl [] = return poly_id tc_inl (L loc (InlineSig _ prag) : other_inls) = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) ; return (poly_id `setInlinePragma` prag) } tc_inl _ = panic "tc_inl" @@ -275,21 +286,9 @@ checkUnboxedTuple :: TcType -> SDoc -> TcM () -- (This shows up as a (more obscure) kind error -- in the 'otherwise' case of tcMonoBinds.) checkUnboxedTuple ty what - = do { zonked_ty <- zonkTcTypeCarefully ty + = do { zonked_ty <- zonkTcType ty ; checkTc (not (isUnboxedTupleType zonked_ty)) (unboxedTupleErr what zonked_ty) } - -------------------- -{- Only needed if we re-add Method constraints -bindInstsOfPatId :: TcId -> TcM a -> TcM (a, TcEvBinds) -bindInstsOfPatId id thing_inside - | not (isOverloadedTy (idType id)) - = do { res <- thing_inside; return (res, emptyTcEvBinds) } - | otherwise - = do { (res, lie) <- captureConstraints thing_inside - ; binds <- bindLocalMethods lie [id] - ; return (res, binds) } --} \end{code} Note [Polymorphism and pattern bindings] diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8a5aab5437..3816984dc2 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1308,7 +1308,13 @@ tcUserStmt (L loc (ExprStmt expr _ _ _)) -- A. [it <- e; print it] but not if it::() -- B. [it <- e] -- C. [let it = e; print it] - ; runPlans [ -- Plan A + -- + -- Ensure that type errors don't get deferred when type checking the + -- naked expression. Deferring type errors here is unhelpful because the + -- expression gets evaluated right away anyway. It also would potentially + -- emit two redundant type-error warnings, one from each plan. + ; unsetDOptM Opt_DeferTypeErrors $ runPlans [ + -- Plan A do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] ; it_ty <- zonkTcType (idType it_id) ; when (isUnitTy it_ty) failM @@ -1458,7 +1464,7 @@ tcRnType hsc_env ictxt normalise rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { - rn_type <- rnLHsType GHCiCtx rdr_type ; + (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ; failIfErrsM ; -- Now kind-check the type diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 351a3e25d0..1d8bdd763f 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -147,6 +147,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_th_ctxt = topStage, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, + tcl_tidy = emptyTidyEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var, tcl_meta = meta_var, @@ -220,6 +221,9 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside %************************************************************************ \begin{code} +discardResult :: TcM a -> TcM () +discardResult a = a >> return () + getTopEnv :: TcRnIf gbl lcl HscEnv getTopEnv = do { env <- getEnv; return (env_top env) } @@ -909,30 +913,11 @@ add_warn_at loc msg extra_info let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg extra_info } ; reportWarning warn } -\end{code} - ------------------------------------ - Tidying -We initialise the "tidy-env", used for tidying types before printing, -by building a reverse map from the in-scope type variables to the -OccName that the programmer originally used for them - -\begin{code} tcInitTidyEnv :: TcM TidyEnv tcInitTidyEnv = do { lcl_env <- getLclEnv - ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty) - | ATyVar name ty <- nameEnvElts (tcl_env lcl_env) - , tcIsTyVarTy ty ] - ; return (foldl add emptyTidyEnv nm_tv_prs) } - where - add (env,subst) (name, tyvar) - = case tidyOccName env (nameOccName name) of - (env', occ') -> (env', extendVarEnv subst tyvar tyvar') - where - tyvar' = setTyVarName tyvar name' - name' = tidyNameOcc name occ' + ; return (tcl_tidy lcl_env) } \end{code} ----------------------------------- diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 8ff3ce3f76..e19ca3574d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -225,8 +225,8 @@ data TcGblEnv -- Updated at intervals (e.g. after dealing with types and classes) tcg_inst_env :: InstEnv, - -- ^ Instance envt for /home-package/ modules; Includes the dfuns in - -- tcg_insts + -- ^ Instance envt for all /home-package/ modules; + -- Includes the dfuns in tcg_insts tcg_fam_inst_env :: FamInstEnv, -- ^ Ditto for family instances -- Now a bunch of things about this module that are simply @@ -429,6 +429,9 @@ data TcLclEnv -- Changes as we move inside an expression tcl_env :: TcTypeEnv, -- The local type environment: Ids and -- TyVars defined in this module + + tcl_tidy :: TidyEnv, -- Used for tidying types; contains all + -- in-scope type variables (but not term variables) tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" -- Namely, the in-scope TyVars bound in tcl_env, @@ -566,8 +569,8 @@ data TcTyThing tct_closed :: TopLevelFlag, -- See Note [Bindings with closed types] tct_level :: ThLevel } - | ATyVar Name TcType -- The type to which the lexically scoped type vaiable - -- is currently refined. We only need the Name + | ATyVar Name TcTyVar -- The type variable to which the lexically scoped type + -- variable is bound. We only need the Name -- for error-message purposes; it is the corresponding -- Name in the domain of the envt @@ -916,9 +919,9 @@ ctPred (CNonCanonical { cc_id = v }) = evVarPred v ctPred (CDictCan { cc_class = cls, cc_tyargs = xis }) = mkClassPred cls xis ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) - = mkEqPred (mkTyVarTy tv, xi) + = mkTcEqPred (mkTyVarTy tv) xi ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) - = mkEqPred(mkTyConApp fn xis1, xi2) + = mkTcEqPred (mkTyConApp fn xis1) xi2 ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) = mkIPPred nm xi ctPred (CIrredEvCan { cc_ty = xi }) = xi diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index f4dafcbeee..bd58c3a537 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -95,7 +95,7 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- Now figure out what to quantify over -- c.f. TcSimplify.simplifyInfer - ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs + ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; let extra_bound_tvs = zonked_forall_tvs `minusVarSet` gbl_tvs @@ -124,8 +124,8 @@ tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs) -- a::*, x :: a->a = do { let ctxt = FunSigCtxt (unLoc var) ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty - ; let skol_tvs = tcSuperSkolTyVars tyvars - id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty + ; let (subst, skol_tvs) = tcSuperSkolTyVars tyvars + id_ty = substTy subst ty id = mkLocalId (unLoc var) id_ty -- The type variables scope over subsequent bindings; yuk diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 660007d7c5..5f87205dfb 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -142,7 +142,7 @@ import TrieMap \begin{code} compatKind :: Kind -> Kind -> Bool -compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 +compatKind k1 k2 = k1 `tcIsSubKind` k2 || k2 `tcIsSubKind` k1 mkKindErrorCtxtTcS :: Type -> Kind -> Type -> Kind @@ -1081,7 +1081,7 @@ warnTcS loc warn_if doc getDefaultInfo :: TcS (SimplContext, [Type], (Bool, Bool)) getDefaultInfo = do { ctxt <- getTcSContext - ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt)) + ; (tys, flags) <- wrapTcS TcM.tcGetDefaultTys ; return (ctxt, tys, flags) } -- Just get some environments needed for instance looking up and matching @@ -1112,7 +1112,7 @@ checkWellStagedDFun pred dfun_id loc bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprType $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprType $ mkEqPred ty1 ty2 isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv @@ -1219,6 +1219,10 @@ data EvVarCreated = EvVarCreated { evc_is_new :: Bool -- True iff the variable was just created , evc_the_evvar :: EvVar } -- The actual evidence variable could be cached or new +instance Outputable EvVarCreated where + ppr (EvVarCreated { evc_is_new = is_new, evc_the_evvar = ev }) + = ppr ev <> parens (if is_new then ptext (sLit "new") else ptext (sLit "old")) + isNewEvVar :: EvVarCreated -> Bool isNewEvVar = evc_is_new @@ -1347,9 +1351,10 @@ newGivenEqVar fl ty1 ty2 co newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated newEqVar fl ty1 ty2 - = newEvVar fl (mkEqPred (ty1,ty2)) - - + = do { let pred = mkTcEqPred ty1 ty2 + ; v <- newEvVar fl pred + ; traceTcS "newEqVar" (ppr v <+> dcolon <+> ppr pred) + ; return v } \end{code} @@ -1418,6 +1423,4 @@ getCtCoercion ct -- solved, so it is not safe to simply do a mkTcCoVarCo (cc_id ct) -- Instead we use the most accurate type, given by ctPred c where maybe_given = isGiven_maybe (cc_flavor ct) - - -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 7ef2549c25..390c70e1fa 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -97,20 +97,19 @@ simplifyDeriv :: CtOrigin -- Simplify 'wanted' as much as possibles -- Fail if not possible simplifyDeriv orig pred tvs theta - = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize + = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. -- We use *non-overlappable* (vanilla) skolems -- See Note [Overlap and deriving] - ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols - subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + ; let subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs skol_set = mkVarSet tvs_skols doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) - ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) + ; traceTc "simplifyDeriv" (pprTvBndrs tvs $$ ppr theta $$ ppr wanted) ; (residual_wanted, _ev_binds1) <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $ solveWanteds $ mkFlatWC wanted @@ -240,7 +239,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds | isEmptyWC wanteds = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked ; zonked_taus <- zonkTcTypes (map snd name_taus) - ; let tvs_to_quantify = tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs + ; let tvs_to_quantify = varSetElems (tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs) -- tvs_to_quantify can contain both kind and type vars -- See Note [Which variables to quantify] ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify @@ -248,13 +247,14 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds | otherwise = do { zonked_wanteds <- zonkWC wanteds - ; zonked_taus <- zonkTcTypes (map snd name_taus) ; gbl_tvs <- tcGetGlobalTyVars + ; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) - , ptext (sLit "taus (zonked) =") <+> ppr zonked_taus + , ptext (sLit "taus =") <+> ppr (map snd name_taus) + , ptext (sLit "tau_tvs (zonked) =") <+> ppr zonked_tau_tvs , ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs , ptext (sLit "closed =") <+> ppr _top_lvl , ptext (sLit "apply_mr =") <+> ppr apply_mr @@ -266,8 +266,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Then split the constraints on the baisis of those tyvars -- to avoid unnecessarily simplifying a class constraint -- See Note [Avoid unecessary constraint simplification] - ; let zonked_tau_tvs = tyVarsOfTypes zonked_taus - proto_qtvs = growWanteds gbl_tvs zonked_wanteds $ + ; let proto_qtvs = growWanteds gbl_tvs zonked_wanteds $ zonked_tau_tvs `minusVarSet` gbl_tvs (perhaps_bound, surely_free) = partitionBag (quantifyMe proto_qtvs) (wc_flat zonked_wanteds) @@ -301,7 +300,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- 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_tau_tvs <- zonkTyVarsAndFV zonked_tau_tvs ; zonked_flats <- zonkCts (wc_flat simpl_results) ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs poly_qtvs = growWantedEVs gbl_tvs zonked_flats init_tvs @@ -333,7 +332,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- they are also bound in ic_skols and we want them to be -- tidied uniformly - ; qtvs_to_return <- zonkQuantifiedTyVars qtvs + ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) -- Step 5 -- Minimize `bound' and emit an implication @@ -786,6 +785,11 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols -- See Note [Solving Family Equations] -- NB: remaining_flats has already had subst applied + ; traceTcS "solveWanteds finished with" $ + vcat [ text "remaining_unsolved_flats =" <+> ppr remaining_unsolved_flats + , text "subst =" <+> ppr subst + ] + ; return $ WC { wc_flat = mapBag (substCt subst) remaining_unsolved_flats , wc_impl = mapBag (substImplication subst) unsolved_implics @@ -1131,7 +1135,7 @@ getSolvableCTyFunEqs untch cts , isTouchableMetaTyVar_InRange untch tv -- And it's a *touchable* unification variable - , typeKind xi `isSubKind` tyVarKind tv + , typeKind xi `tcIsSubKind` tyVarKind tv -- Must do a small kind check since TcCanonical invariants -- on family equations only impose compatibility, not subkinding diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index a6b2a10aa6..79f4169309 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -7,7 +7,7 @@ TcSplice: Template Haskell splices \begin{code} -module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, +module TcSplice( tcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket, lookupThName_maybe, runQuasiQuoteExpr, runQuasiQuotePat, runQuasiQuoteDecl, runQuasiQuoteType, @@ -286,7 +286,7 @@ The predicate we use is TcEnv.thTopLevelId. tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) -- None of these functions add constraints to the LIE lookupThName_maybe :: TH.Name -> TcM (Maybe Name) @@ -302,7 +302,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) -kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) +tcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) @@ -517,12 +517,12 @@ tcTopSpliceExpr tc_action Very like splicing an expression, but we don't yet share code. \begin{code} -kcSpliceType splice@(HsSplice name hs_expr) fvs +tcSpliceType (HsSplice name hs_expr) _ = setSrcSpan (getLoc hs_expr) $ do { stage <- getStage ; case stage of { - Splice -> kcTopSpliceType hs_expr ; - Comp -> kcTopSpliceType hs_expr ; + Splice -> tcTopSpliceType hs_expr ; + Comp -> tcTopSpliceType hs_expr ; Brack pop_level ps_var lie_var -> do -- See Note [How brackets and nested splices are handled] @@ -541,12 +541,13 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs -- but $(h 4) :: a i.e. any type, of any kind ; kind <- newMetaKindVar - ; return (HsSpliceTy splice fvs kind, kind) + ; ty <- newFlexiTyVarTy kind + ; return (ty, kind) }}} -kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) +tcTopSpliceType :: LHsExpr Name -> TcM (TcType, TcKind) -- Note [How top-level splices are handled] -kcTopSpliceType expr +tcTopSpliceType expr = do { meta_ty <- tcMetaTy typeQTyConName -- Typecheck the expression @@ -560,9 +561,8 @@ kcTopSpliceType expr -- otherwise the type checker just gives more spurious errors ; addErrCtxt (spliceResultDoc expr) $ do { let doc = SpliceTypeCtx hs_ty2 - ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2) - ; (ty4, kind) <- kcLHsType hs_ty3 - ; return (unLoc ty4, kind) }} + ; (hs_ty3, _fvs) <- checkNoErrs (rnLHsType doc hs_ty2) + ; tcLHsType hs_ty3 }} \end{code} %************************************************************************ @@ -1005,9 +1005,9 @@ reifyInstances th_nm th_tys <+> int tc_arity <> rparen)) ; loc <- getSrcSpanM ; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName - ; rn_tys <- rnLHsTypes doc rdr_tys -- Rename to HsType Name - ; (tys, _res_k) <- kcApps tc (tyConKind tc) rn_tys - ; mapM dsHsType tys } + ; (rn_tys, _fvs) <- rnLHsTypes doc rdr_tys -- Rename to HsType Name + ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys + ; return tys } cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) cvt loc th_ty = case convertToHsType loc th_ty of @@ -1157,10 +1157,10 @@ reifyThing (ATcId {tct_id = id}) ; fix <- reifyFixity (idName id) ; return (TH.VarI (reifyName id) ty2 Nothing fix) } -reifyThing (ATyVar tv ty) - = do { ty1 <- zonkTcType ty - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } +reifyThing (ATyVar tv tv1) + = do { ty1 <- zonkTcTyVar tv1 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } reifyThing (AThing {}) = panic "reifyThing AThing" reifyThing ANothing = panic "reifyThing ANothing" diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 18a31b0b93..de14aa3b95 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -1,12 +1,12 @@ \begin{code} module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, - HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) + HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) import Name ( Name ) import NameSet ( FreeVars ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) -import TcType ( TcRhoType, TcKind ) +import TcType ( TcRhoType, TcType, TcKind ) import Annotations ( Annotation, CoreAnnTarget ) import qualified Language.Haskell.TH as TH @@ -14,8 +14,7 @@ tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> FreeVars - -> TcM (HsType Name, TcKind) +tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) tcBracket :: HsBracket Name -> TcRhoType diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 95d7d236a7..c166e6210e 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -31,6 +31,7 @@ import BuildTyCl import TcUnify import TcRnMonad import TcEnv +import TcHsSyn import TcBinds( tcRecSelBinds ) import TcTyDecls import TcClassDcl @@ -77,7 +78,6 @@ import Data.List Note [Grouping of type and class declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly connected component of mutually dependent types and classes. We kind check and type check each group separately to enhance kind polymorphism. Take the @@ -219,11 +219,11 @@ So we infer their kinds in dependency order We need to kind check all types in the mutually recursive group before we know the kind of the type variables. For example: -class C a where - op :: D b => a -> b -> b + class C a where + op :: D b => a -> b -> b -class D c where - bop :: (Monad c) => ... + class D c where + bop :: (Monad c) => ... Here, the kind of the locally-polymorphic type variable "b" depends on *all the uses of class D*. For example, the use of @@ -276,12 +276,15 @@ kcTyClGroup decls ; setLclEnv tcl_env $ do -- Step 3: kind-check the synonyms - { mapM_ (wrapLocM kcTyClDecl) non_syn_decls + { mapM_ kcLTyClDecl non_syn_decls -- Step 4: generalisation -- Kind checking done for this group -- Now we have to kind generalize the flexis - ; mapM generalise (tyClsBinders decls) }}} + ; res <- mapM generalise (tyClsBinders decls) + + ; traceTc "kcTyClGroup result" (ppr res) + ; return res }}} where generalise :: Name -> TcM (Name, Kind) @@ -291,7 +294,8 @@ kcTyClGroup decls ; let kc_kind = case thing of AThing k -> k _ -> pprPanic "kcTyClGroup" (ppr thing) - ; (kvs, kc_kind') <- kindGeneralizeKind kc_kind + ; kvs <- kindGeneralize (tyVarsOfType kc_kind) + ; kc_kind' <- zonkTcKind kc_kind ; return (name, mkForAllTys kvs kc_kind') } getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] @@ -301,28 +305,18 @@ getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)] -- of the definition (and probably including -- kind unification variables) -- Example: data T a b = ... --- return (T, kv1 -> kv2 -> *) +-- return (T, kv1 -> kv2 -> kv3) -- -- ALSO for each datacon, return (dc, ANothing) -- See Note [ANothing] in TcRnTypes getInitialKinds (L _ decl) - = do { arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl) - ; res_kind <- mk_res_kind decl + = do { arg_kinds <- mapM (\_ -> newMetaKindVar) (tyClDeclTyVars decl) + ; res_kind <- get_res_kind decl ; let main_pair = (tcdName decl, AThing (mkArrowKinds arg_kinds res_kind)) ; inner_pairs <- get_inner_kinds decl ; return (main_pair : inner_pairs) } where - mk_arg_kind (UserTyVar _ _) = newMetaKindVar - mk_arg_kind (KindedTyVar _ kind _) = scDsLHsKind kind - - mk_res_kind (TyFamily { tcdKind = Just kind }) = scDsLHsKind kind - mk_res_kind (TyData { tcdKindSig = Just kind }) = scDsLHsKind kind - -- On GADT-style declarations we allow a kind signature - -- data T :: *->* where { ... } - mk_res_kind (ClassDecl {}) = return constraintKind - mk_res_kind _ = return liftedTypeKind - get_inner_kinds :: TyClDecl Name -> TcM [(Name,TcTyThing)] get_inner_kinds (TyData { tcdCons = cons }) = return [ (unLoc (con_name con), ANothing) | L _ con <- cons ] @@ -331,14 +325,13 @@ getInitialKinds (L _ decl) get_inner_kinds _ = return [] -kcLookupKind :: Located Name -> TcM Kind -kcLookupKind nm = do - tc_ty_thing <- tcLookupLocated nm - case tc_ty_thing of - AThing k -> return k - AGlobal (ATyCon tc) -> return (tyConKind tc) - _ -> pprPanic "kcLookupKind" (ppr tc_ty_thing) - + get_res_kind (ClassDecl {}) = return constraintKind + get_res_kind (TyData { tcdKindSig = Nothing }) = return liftedTypeKind + get_res_kind _ = newMetaKindVar + -- Warning: you might be tempted to return * for all data decls + -- but on GADT-style declarations we allow a kind signature + -- data T :: *->* where { ... } + -- with *no tyClDeclTyVars* ---------------- kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings @@ -356,138 +349,96 @@ kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } -- of out-of-scope tycons kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) -kcSynDecl decl -- Vanilla type synonyoms only, not family instances +kcSynDecl decl@(TySynonym { tcdTyVars = hs_tvs, tcdLName = L _ name + , tcdSynRhs = rhs }) + -- Vanilla type synonyoms only, not family instances + -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ - kcHsTyVars (tcdTyVars decl) $ \ k_tvs -> - do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) - <+> brackets (ppr k_tvs)) - ; (_, rhs_kind) <- kcLHsType (tcdSynRhs decl) - ; traceTc "kcd2" (ppr (tcdName decl)) - ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs - ; return (tcdName decl, tc_kind) } + tcHsTyVarBndrs (tcdTyVars decl) $ \ k_tvs -> + do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs) + <+> brackets (ppr k_tvs)) + ; (_, rhs_kind) <- tcLHsType rhs + ; traceTc "kcd2" (ppr name) + ; let tc_kind = foldr (mkArrowKind . tyVarKind) rhs_kind k_tvs + ; return (name, tc_kind) } +kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) ------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl Name -> TcM () +kcLTyClDecl (L loc decl) + = setSrcSpan loc $ tcAddDeclCtxt decl $ kcTyClDecl decl + kcTyClDecl :: TyClDecl Name -> TcM () -- This function is used solely for its side effect on kind variables -kcTyClDecl (ForeignType {}) - = return () -kcTyClDecl decl@(TyFamily {}) - = kcFamilyDecl [] decl -- the empty list signals a toplevel decl - -kcTyClDecl decl@(TyData {}) +kcTyClDecl decl@(TyData { tcdLName = L _ name, tcdTyVars = hs_tvs }) = 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}) - = kcTyClDeclBody decl $ \ tvs' -> - do { discardResult (kcHsContext ctxt) - ; mapM_ (wrapLocM (kcFamilyDecl tvs')) ats - ; mapM_ (wrapLocM kc_sig) sigs } + kcTyClTyVars name hs_tvs $ \ res_k -> kcDataDecl decl res_k + +kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats}) + = kcTyClTyVars name hs_tvs $ \ res_k -> + do { _ <- tcHsContext ctxt + ; _ <- unifyKind res_k constraintKind + ; mapM_ (wrapLocM kcFamilyDecl) ats + ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (TypeSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) - kc_sig (GenericSig _ op_ty) = discardResult (kcHsLiftedSigType op_ty) + kc_sig (TypeSig _ op_ty) = discardResult (tcHsLiftedType op_ty) + kc_sig (GenericSig _ op_ty) = discardResult (tcHsLiftedType op_ty) kc_sig _ = return () -kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl - = panic "kcTyClDecl TySynonym" - --------------------- -kcTyClDeclBody :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> TcM a) - -> TcM a --- getInitialKind has made a suitably-shaped kind for the type or class --- Unpack it, and attribute those kinds to the type variables --- Extend the env with bindings for the tyvars, taken from --- the kind of the tycon/class. Give it to the thing inside, and --- check the result kind matches -kcTyClDeclBody decl thing_inside - = tcAddDeclCtxt decl $ - do { tc_kind <- kcLookupKind (tcdLName decl) - ; let (kinds, _) = splitKindFunTys tc_kind - hs_tvs = tcdTyVars decl - kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - zipWith add_kind hs_tvs kinds - ; tcExtendKindEnvTvs kinded_tvs thing_inside } - where - add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) - add_kind (L loc (KindedTyVar n hsk _)) k = L loc (KindedTyVar n hsk k) +kcTyClDecl (ForeignType {}) = return () +kcTyClDecl decl@(TyFamily {}) = kcFamilyDecl decl + +kcTyClDecl (TySynonym {}) -- Type synonyms are never passed to kcTyClDecl + = panic "kcTyClDecl TySynonym" -- See Note [Kind checking for type and class decls] ------------------- -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these -- kinded type variables are also passed as the second parameter). -- -kcDataDecl :: TyClDecl Name -> TcM () -kcDataDecl (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) - = do { _ <- kcHsContext ctxt - ; _ <- mapM (wrapLocM (kcConDecl new_or_data)) cons - ; return () } -kcDataDecl d = pprPanic "kcDataDecl" (ppr d) +kcDataDecl :: TyClDecl Name -> Kind -> TcM () +kcDataDecl (TyData { tcdND = new_or_data, tcdCtxt = ctxt + , tcdCons = cons, tcdKindSig = mb_kind }) res_k + = do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocM (kcConDecl new_or_data)) cons + ; kcResultKind mb_kind res_k } +kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d) ------------------- -kcConDecl :: NewOrData -> ConDecl Name -> TcM (ConDecl Name) - -- doc comments are typechecked to Nothing here -kcConDecl new_or_data con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details, con_res = res }) +kcConDecl :: NewOrData -> ConDecl Name -> TcM () +kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) = addErrCtxt (dataConCtxt name) $ - kcHsTyVars ex_tvs $ \ex_tvs' -> - do { ex_ctxt' <- kcHsContext ex_ctxt - ; details' <- kc_con_details details - ; res' <- case res of - ResTyH98 -> return ResTyH98 - ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' - , con_details = details', con_res = res' }) } - where - kc_con_details (PrefixCon btys) - = do { btys' <- mapM kc_larg_ty btys - ; return (PrefixCon btys') } - kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_larg_ty bty1 - ; bty2' <- kc_larg_ty bty2 - ; return (InfixCon bty1' bty2') } - kc_con_details (RecCon fields) - = do { fields' <- mapM kc_field fields - ; return (RecCon fields') } - - kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty - ; return (ConDeclField fld bty' d) } - - kc_larg_ty bty = case new_or_data of - DataType -> kcHsSigType bty - NewType -> kcHsLiftedSigType bty - -- Can't allow an unlifted type for newtypes, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. - -- And newtypes can't be bang'd + tcHsTyVarBndrs ex_tvs $ \ _ -> + do { _ <- tcHsContext ex_ctxt + ; mapM_ (tcHsConArgType new_or_data) (hsConDeclArgTys details) + ; _ <- tcConRes res + ; return () } ------------------- -- Kind check a family declaration or type family default declaration. -- -kcFamilyDecl :: [LHsTyVarBndr Name] -- tyvars of enclosing class decl if any - -> TyClDecl Name -> TcM () -kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) - = kcTyClDeclBody decl $ \tvs' -> - do { mapM_ unifyClassParmKinds tvs' - ; discardResult (scDsLHsMaybeKind kind) } - where - unifyClassParmKinds (L _ tv) - | (n,k) <- hsTyVarNameKind tv - , Just classParmKind <- lookup n classTyKinds - = let ctxt = ptext ( sLit "When kind checking family declaration") - <+> ppr (tcdLName decl) - in addErrCtxt ctxt $ unifyKind k classParmKind >> return () - | otherwise = return () - classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] - -kcFamilyDecl _ (TySynonym {}) = return () +kcFamilyDecl :: TyClDecl Name -> TcM () +kcFamilyDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs + , tcdKindSig = mb_kind}) + = kcTyClTyVars name hs_tvs $ \res_k -> kcResultKind mb_kind res_k + +kcFamilyDecl (TySynonym {}) = return () -- We don't have to do anything here for type family defaults: -- tcClassATs will use tcAssocDecl to check them -kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) - -------------------- -discardResult :: TcM a -> TcM () -discardResult a = a >> return () +kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d) + +------------------ +kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM () +kcResultKind Nothing res_k + = discardResult (unifyKind res_k liftedTypeKind) + -- type family F a + -- defaults to type family F a :: * +kcResultKind (Just k) res_k + = do { k' <- tcLHsKind k + ; discardResult (unifyKind k' res_k) } \end{code} @@ -566,32 +517,36 @@ 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 [] + tycon = buildAlgTyCon tc_name final_tvs Nothing [] DataFamilyTyCon Recursive True parent ; return [ATyCon tycon] } -- "type" synonym declaration tcTyClDecl1 _parent _calc_isrec - (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = hs_ty}) = ASSERT( isNoParent _parent ) tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { rhs_ty' <- tcCheckHsType rhs_ty kind - ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') - kind NoParentTyCon + { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) + ; rhs_ty <- tcCheckLHsType hs_ty kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty) + kind NoParentTyCon ; return [ATyCon tycon] } -- "newtype" and "data" -- NB: not used for newtype/data instances (whether associated or not) tcTyClDecl1 _parent calc_isrec - (TyData { tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs + (TyData { tcdND = new_or_data, tcdCType = cType + , tcdCtxt = ctxt, tcdTyVars = tvs , tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons }) = ASSERT( isNoParent _parent ) - let is_rec = calc_isrec tc_name - h98_syntax = consUseH98Syntax cons in tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { extra_tvs <- tcDataKindSig kind - ; let final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcHsKindedContext =<< kcHsContext ctxt + ; let is_rec = calc_isrec tc_name + h98_syntax = consUseH98Syntax cons + final_tvs = tvs' ++ extra_tvs + ; stupid_theta <- tcHsContext ctxt ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs @@ -613,7 +568,7 @@ tcTyClDecl1 _parent calc_isrec DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) - ; return (buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs + ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs is_rec (not h98_syntax) NoParentTyCon) } ; return [ATyCon tycon] } @@ -626,10 +581,15 @@ tcTyClDecl1 _parent calc_isrec { (tvs', ctxt', fds', sig_stuff, gen_dm_env) <- tcTyClTyVars class_name tvs $ \ tvs' kind -> do { MASSERT( isConstraintKind kind ) - ; ctxt' <- tcHsKindedContext =<< kcHsContext ctxt - ; fds' <- mapM (addLocM tc_fundep) fundeps + + ; ctxt' <- tcHsContext ctxt + ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' + -- Squeeze out any kind unification variables + + ; fds' <- mapM (addLocM tc_fundep) fundeps ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; return (tvs', ctxt', fds', sig_stuff, gen_dm_env) } + ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we @@ -638,8 +598,6 @@ tcTyClDecl1 _parent calc_isrec tc_isrec = calc_isrec tycon_name ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs - -- NB: 'ats' only contains "type family" and "data family" declarations - -- and 'at_defs' only contains associated-type defaults ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' at_stuff @@ -709,7 +667,8 @@ tcClassATs class_name parent ats at_defs at_defs_map :: NameEnv [LTyClDecl Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv (tcdName (unLoc at_def)) [at_def]) + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (tcdName (unLoc at_def)) [at_def]) emptyNameEnv at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcTyClDecl1 parent @@ -731,27 +690,28 @@ tcDefaultAssocDecl fam_tc (L loc decl) ; (at_tvs, at_tys, at_rhs) <- tcSynFamInstDecl fam_tc decl ; return (ATD at_tvs at_tys at_rhs loc) } -- We check for well-formedness and validity later, in checkValidClass -------------------------- +------------------------- tcSynFamInstDecl :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type) +-- Placed here because type family instances appear as +-- default decls in class declarations tcSynFamInstDecl fam_tc (TySynonym { tcdTyVars = tvs, tcdTyPats = Just pats - , tcdSynRhs = rhs }) + , tcdSynRhs = hs_ty }) = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; let kc_rhs rhs kind = kcCheckLHsType rhs (EK kind (ptext (sLit "Expected"))) - - ; tcFamTyPats fam_tc tvs pats (kc_rhs rhs) + ; tcFamTyPats fam_tc tvs pats + (discardResult . tcCheckLHsType hs_ty) $ \tvs' pats' res_kind -> do - - { rhs' <- kc_rhs rhs res_kind - ; rhs'' <- tcHsKindedType rhs' - - ; return (tvs', pats', rhs'') } } + { rhs_ty <- tcCheckLHsType hs_ty res_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; traceTc "tcSynFamInstDecl" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) + ; return (tvs', pats', rhs_ty) } } tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ------------------------- -- Kind check type patterns and kind annotate the embedded type variables. +-- type instance F [a] = rhs -- -- * Here we check that a type instance matches its kind signature, but we do -- not check whether there is a pattern for each type index; the latter @@ -760,9 +720,9 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl) ----------------- tcFamTyPats :: TyCon -> [LHsTyVarBndr Name] -> [LHsType Name] - -> (TcKind -> TcM any) -- Kind checker for RHS + -> (TcKind -> TcM ()) -- Kind checker for RHS -- result is ignored - -> ([KindVar] -> [TcKind] -> Kind -> TcM a) + -> ([TKVar] -> [TcType] -> Kind -> TcM a) -> TcM a -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -775,42 +735,35 @@ tcFamTyPats :: TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tcFamTyPats fam_tc tyvars pats kind_checker thing_inside - = kcHsTyVars tyvars $ \tvs -> - do { let (fam_kvs, body) = splitForAllTys (tyConKind fam_tc) - - -- A family instance must have exactly the same number of type +tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside + = do { -- A family instance must have exactly the same number of type -- parameters as the family declaration. You can't write -- type family F a :: * -> * -- type instance F Int y = y -- because then the type (F Int) would be like (\y.y) - ; let fam_arity = tyConArity fam_tc - length fam_kvs - ; checkTc (length pats == fam_arity) $ + ; let (fam_kvs, fam_body) = splitForAllTys (tyConKind fam_tc) + fam_arity = tyConArity fam_tc - length fam_kvs + ; checkTc (length arg_pats == fam_arity) $ wrongNumberOfParmsErr fam_arity -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs - ; let body' = substKiWith fam_kvs fam_arg_kinds body - (kinds, resKind) = splitKindFunTysN fam_arity body' - ; typats <- zipWithM kcCheckLHsType pats - [ expArgKind (quotes (ppr fam_tc)) kind n - | (kind,n) <- kinds `zip` [1..]] - - -- Kind check the "thing inside"; this just works by - -- side-effecting any kind unification variables - ; _ <- kind_checker resKind - - -- Type check indexed data type declaration - -- We kind generalize the kind patterns since they contain - -- all the meta kind variables - -- See Note [Quantifying over family patterns] - ; tcTyVarBndrsKindGen tvs $ \tvs' -> do { + ; let (arg_kinds, res_kind) + = splitKindFunTysN fam_arity $ + substKiWith fam_kvs fam_arg_kinds fam_body - ; (t_kvs, fam_arg_kinds') <- kindGeneralizeKinds fam_arg_kinds - ; k_typats <- mapM tcHsKindedType typats - - ; thing_inside (t_kvs ++ tvs') (fam_arg_kinds' ++ k_typats) resKind } - } + -- Kind-check and quantify + -- See Note [Quantifying over family patterns] + ; (tkvs, typats) <- tcHsTyVarBndrsGen tyvars $ do + { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds + ; kind_checker res_kind + ; return (tyVarsOfTypes typats, typats) } + + ; all_args' <- zonkTcTypeToTypes emptyZonkEnv (fam_arg_kinds ++ typats) + ; res_kind' <- zonkTcTypeToType emptyZonkEnv res_kind + ; traceTc "tcFamPats" (ppr tkvs $$ ppr all_args' $$ ppr res_kind') + ; tcExtendTyVarEnv tkvs $ + thing_inside tkvs all_args' res_kind' } \end{code} Note [Quantifying over family patterns] @@ -915,40 +868,79 @@ tcConDecl :: NewOrData -> TcM DataCon tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types - con@(ConDecl {con_name = name}) - = do - { ConDecl { con_qvars = tvs, con_cxt = ctxt - , con_details = details, con_res = res_ty } - <- kcConDecl new_or_data con - ; addErrCtxt (dataConCtxt name) $ - tcTyVarBndrsKindGen tvs $ \ tvs' -> do - { ctxt' <- tcHsKindedContext ctxt - ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) - (badExistential name) - ; traceTc "tcConDecl 1" (ppr con) - ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty - ; let - tc_datacon is_infix field_lbls btys - = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys - ; traceTc "tcConDecl 3" (ppr name) - - ; buildDataCon (unLoc name) is_infix - stricts field_lbls - univ_tvs ex_tvs eq_preds ctxt' arg_tys - res_ty' rep_tycon } + con@(ConDecl { con_name = name + , con_qvars = tvs, con_cxt = ctxt + , con_details = details, con_res = res_ty }) + = addErrCtxt (dataConCtxt name) $ + do { traceTc "tcConDecl 1" (ppr name) + ; (tvs', (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) + <- tcHsTyVarBndrsGen tvs $ + do { ctxt' <- tcHsContext ctxt + ; details' <- tcConArgs new_or_data details + ; res_ty' <- tcConRes res_ty + ; let (is_infix, field_lbls, btys') = details' + (arg_tys', stricts) = unzip btys' + ftvs = tyVarsOfTypes ctxt' `unionVarSet` + tyVarsOfTypes arg_tys' `unionVarSet` + case res_ty' of + ResTyH98 -> emptyVarSet + ResTyGADT ty -> tyVarsOfType ty + ; return (ftvs, (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) } + + + -- Substitute, to account for the kind + -- unifications done by tcHsTyVarBndrsGen + ; traceTc "tcConDecl 2" (ppr name) + ; let ze = mkTyVarZonkEnv tvs' + ; arg_tys' <- zonkTcTypeToTypes ze arg_tys' + ; ctxt' <- zonkTcTypeToTypes ze ctxt' + ; res_ty' <- case res_ty' of + ResTyH98 -> return ResTyH98 + ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty + + ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) + (badExistential name) + + ; let (univ_tvs, ex_tvs, eq_preds, res_ty'') + = rejigConRes res_tmpl tvs' res_ty' + + ; traceTc "tcConDecl 3" (ppr name) + ; buildDataCon (unLoc name) is_infix + stricts field_lbls + univ_tvs ex_tvs eq_preds ctxt' arg_tys' + res_ty'' rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. + } + +tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)]) +tcConArgs new_or_data (PrefixCon btys) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (False, [], btys') } +tcConArgs new_or_data (InfixCon bty1 bty2) + = do { bty1' <- tcConArg new_or_data bty1 + ; bty2' <- tcConArg new_or_data bty2 + ; return (True, [], [bty1', bty2']) } +tcConArgs new_or_data (RecCon fields) + = do { btys' <- mapM (tcConArg new_or_data) btys + ; return (False, field_names, btys') } + where + field_names = map (unLoc . cd_fld_name) fields + btys = map cd_fld_type fields + +tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang) +tcConArg new_or_data bty + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcHsConArgType new_or_data bty + ; traceTc "tcConArg 2" (ppr bty) + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) + ; return (arg_ty, strict_mark) } - ; traceTc "tcConDecl 2" (ppr name) - ; case details of - PrefixCon btys -> tc_datacon False [] btys - InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] - RecCon fields -> tc_datacon False field_names btys - where - field_names = map (unLoc . cd_fld_name) fields - btys = map cd_fld_type fields - } } +tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) +tcConRes ResTyH98 = return ResTyH98 +tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty + ; return (ResTyGADT res_ty') } -- Example -- data instance T (b,c) where @@ -959,26 +951,26 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl -- Data types -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 -- In this case orig_res_ty = T (e,e) -tcResultType :: ([TyVar], Type) -- Template for result type; e.g. +rejigConRes :: ([TyVar], Type) -- Template for result type; e.g. -- data instance T [a] b c = ... -- gives template ([a,b,c], T [a] b c) -> [TyVar] -- where MkT :: forall x y z. ... - -> ResType Name - -> TcM ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [(TyVar,Type)], -- Equality predicates - Type) -- Typechecked return type + -> ResType Type + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [(TyVar,Type)], -- Equality predicates + Type) -- Typechecked return type -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because we are in the middle -- of a recursive knot; so it's postponed until checkValidDataCon -tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98 - = return (tmpl_tvs, dc_tvs, [], res_ty) +rejigConRes (tmpl_tvs, res_ty) dc_tvs ResTyH98 + = (tmpl_tvs, dc_tvs, [], res_ty) -- In H98 syntax the dc_tvs are the existential ones -- data T a b c = forall d e. MkT ... -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs -tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) +rejigConRes (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- Then we generate @@ -988,8 +980,9 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- z -- Existentials are the leftover type vars: [x,y] -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) - = do { res_ty' <- tcHsKindedType res_ty - ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty' + = (univ_tvs, ex_tvs, eq_spec, res_ty) + where + Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty -- This 'Just' pattern is sure to match, because if not -- checkValidDataCon will complain first. The 'subst' -- should not be looked at until after checkValidDataCon @@ -998,20 +991,18 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- /Lazily/ figure out the univ_tvs etc -- Each univ_tv is either a dc_tv or a tmpl_tv - (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs - choose tmpl (univs, eqs) - | Just ty <- lookupTyVar subst tmpl - = case tcGetTyVar_maybe ty of - Just tv | not (tv `elem` univs) - -> (tv:univs, eqs) - _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) - where -- see Note [Substitution in template variables kinds] - new_tmpl = updateTyVarKind (substTy subst) tmpl - | otherwise = pprPanic "tcResultType" (ppr res_ty) - ex_tvs = dc_tvs `minusList` univ_tvs - - ; return (univ_tvs, ex_tvs, eq_spec, res_ty') } - where + (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs + choose tmpl (univs, eqs) + | Just ty <- lookupTyVar subst tmpl + = case tcGetTyVar_maybe ty of + Just tv | not (tv `elem` univs) + -> (tv:univs, eqs) + _other -> (new_tmpl:univs, (new_tmpl,ty):eqs) + where -- see Note [Substitution in template variables kinds] + new_tmpl = updateTyVarKind (substTy subst) tmpl + | otherwise = pprPanic "tcResultType" (ppr res_ty) + ex_tvs = dc_tvs `minusList` univ_tvs + -- NB: tmpl_tvs and dc_tvs are distinct, but -- we want them to be *visibly* distinct, both for -- interface files and general confusion. So rename @@ -1083,13 +1074,6 @@ conRepresentibleWithH98Syntax f _ _ = False ------------------- -tcConArg :: LHsType Name -> TcM (TcType, HsBang) -tcConArg bty - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcHsBangType bty - ; traceTc "tcConArg 2" (ppr bty) - ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) - ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -1364,7 +1348,7 @@ checkValidClass 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 + unary = count isTypeVar tyvars == 1 -- Ignore kind variables check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 8f3ec5b4b9..e7acc3a9a2 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -25,7 +25,6 @@ module TcTyDecls( import TypeRep import HsSyn -import RnHsSyn import Class import Type import HscTypes @@ -62,7 +61,7 @@ We check for type synonym and class cycles on the *source* code. Main reasons: a) Otherwise we'd need a special function to extract type-synonym tycons - from a type, whereas we have extractHsTyNames already + from a type, whereas we already have the free vars pinned on the decl b) If we checked for type synonym loops after building the TyCon, we can't do a hoistForAllTys on the type synonym rhs, (else we fall into @@ -111,11 +110,8 @@ synTyConsOfType ty \begin{code} mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] mkSynEdges syn_decls = [ (ldecl, unLoc (tcdLName decl), - mk_syn_edges (tcdSynRhs decl)) + nameSetToList (tcdFVs decl)) | ldecl@(L _ decl) <- syn_decls ] - where - mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), - not (isTyVarName tc) ] calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index bf4e1b203c..6b99a1f53b 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -37,10 +37,11 @@ module TcType ( isSigTyVar, isOverlappableTyVar, isTyConableTyVar, isAmbiguousTyVar, metaTvRef, isFlexi, isIndirect, isRuntimeUnkSkol, + isTypeVar, isKindVar, -------------------------------- -- Builders - mkPhiTy, mkSigmaTy, + mkPhiTy, mkSigmaTy, mkTcEqPred, -------------------------------- -- Splitters @@ -88,7 +89,7 @@ module TcType ( tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyTyVarBndr, tidyFreeTyVars, + tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTyVarOcc, tidyTopType, @@ -118,7 +119,7 @@ module TcType ( unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, + isSubArgTypeKind, tcIsSubKind, splitKindFunTys, defaultKind, mkMetaKindVar, -------------------------------- @@ -133,7 +134,7 @@ module TcType ( mkClassPred, mkIPPred, isDictLikeTy, tcSplitDFunTy, tcSplitDFunHead, - mkEqPred, + mkEqPred, -- Type substitutions TvSubst(..), -- Representation visible to a few friends @@ -390,11 +391,7 @@ mkKindName unique = mkSystemName unique kind_var_occ mkMetaKindVar :: Unique -> IORef MetaDetails -> MetaKindVar mkMetaKindVar u r - = mkTcTyVar (mkKindName u) - tySuperKind -- not sure this is right, - -- do we need kind vars for - -- coercions? - (MetaTv TauTv r) + = mkTcTyVar (mkKindName u) superKind (MetaTv TauTv r) kind_var_occ :: OccName -- Just one for all MetaKindVars -- They may be jiggled by tidying @@ -453,6 +450,9 @@ Tidying is here becuase it has a special case for FlatSkol -- an interface file. -- -- It doesn't change the uniques at all, just the print names. +tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) +tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs + tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) tidyTyVarBndr tidy_env@(occ_env, subst) tyvar = case tidyOccName occ_env occ1 of @@ -777,6 +777,17 @@ mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type mkPhiTy theta ty = foldr mkFunTy ty theta + +mkTcEqPred :: TcType -> TcType -> Type +-- During type checking we build equalities between +-- type variables with OpenKind or ArgKind. Ultimately +-- they will all settle, but we want the equality predicate +-- itself to have kind '*'. I think. +-- +-- But this is horribly delicate: what about type variables +-- that turn out to be bound to Int#? +mkTcEqPred ty1 ty2 + = mkNakedEqPred (defaultKind (typeKind ty1)) ty1 ty2 \end{code} @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 566534c192..a54d420b98 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -16,7 +16,7 @@ Type subsumption and unification module TcUnify ( -- Full-blown subsumption tcWrapResult, tcSubType, tcGen, - checkConstraints, newImplication, sigCtxt, + checkConstraints, newImplication, -- Various unifications unifyType, unifyTypeList, unifyTheta, unifyKind, unifyKindEq, @@ -654,12 +654,11 @@ unifySigmaTy origin ty1 ty2 (tvs2, body2) = tcSplitForAllTys ty2 ; defer_or_continue (not (equalLength tvs1 tvs2)) $ do { - skol_tvs <- tcInstSkolTyVars tvs1 + (subst1, 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 + phi1 = Type.substTy subst1 body1 + phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2 skol_info = UnifyForAllSkol skol_tvs phi1 ; (ev_binds, co) <- checkConstraints skol_info skol_tvs [] $ @@ -1166,7 +1165,7 @@ uUnboundKVar kv1 k2@(TyVarTy kv2) uUnboundKVar kv1 non_var_k2 = do { k2' <- zonkTcKind non_var_k2 ; kindOccurCheck kv1 k2' - ; let k2'' = kindSimpleKind k2' + ; let k2'' = defaultKind k2' -- MetaKindVars must be bound only to simple kinds ; writeMetaTyVar kv1 k2'' } @@ -1177,13 +1176,6 @@ kindOccurCheck kv1 k2 -- k2 is zonked then failWithTc (kindOccurCheckErr kv1 k2) else return () -kindSimpleKind :: Kind -> SimpleKind --- (kindSimpleKind k) returns a simple kind k' such that k' <= k -kindSimpleKind k - | isOpenTypeKind k = liftedTypeKind - | isArgTypeKind k = liftedTypeKind - | otherwise = k - mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) mkKindErrorCtxt ty1 ty2 k1 k2 env0 = let (env1, ty1') = tidyOpenType env0 ty1 @@ -1215,131 +1207,3 @@ kindOccurCheckErr tyvar ty = hang (ptext (sLit "Occurs check: cannot construct the infinite kind:")) 2 (sep [ppr tyvar, char '=', ppr ty]) \end{code} - -%************************************************************************ -%* * -\subsection{Checking signature type variables} -%* * -%************************************************************************ - -@checkSigTyVars@ checks that a set of universally quantified type varaibles -are not mentioned in the environment. In particular: - - (a) Not mentioned in the type of a variable in the envt - eg the signature for f in this: - - g x = ... where - f :: a->[a] - f y = [x,y] - - Here, f is forced to be monorphic by the free occurence of x. - - (d) Not (unified with another type variable that is) in scope. - eg f x :: (r->r) = (\y->y) :: forall a. a->r - when checking the expression type signature, we find that - even though there is nothing in scope whose type mentions r, - nevertheless the type signature for the expression isn't right. - - Another example is in a class or instance declaration: - class C a where - op :: forall b. a -> b - op x = x - Here, b gets unified with a - -Before doing this, the substitution is applied to the signature type variable. - --- \begin{code} -checkSigTyVars :: [TcTyVar] -> TcM () -checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs - -checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM () --- The extra_tvs can include boxy type variables; --- e.g. TcMatches.tcCheckExistentialPat -checkSigTyVarsWrt extra_tvs sig_tvs - = do { extra_tvs' <- zonkTcTyVarsAndFV extra_tvs - ; check_sig_tyvars extra_tvs' sig_tvs } - -check_sig_tyvars - :: TcTyVarSet -- Global type variables. The universally quantified - -- tyvars should not mention any of these - -- Guaranteed already zonked. - -> [TcTyVar] -- Universally-quantified type variables in the signature - -- Guaranteed to be skolems - -> TcM () -check_sig_tyvars _ [] - = return () -check_sig_tyvars extra_tvs sig_tvs - = ASSERT( all isTcTyVar sig_tvs && all isSkolemTyVar sig_tvs ) - do { gbl_tvs <- tcGetGlobalTyVars - ; traceTc "check_sig_tyvars" $ vcat - [ text "sig_tys" <+> ppr sig_tvs - , text "gbl_tvs" <+> ppr gbl_tvs - , text "extra_tvs" <+> ppr extra_tvs] - - ; let env_tvs = gbl_tvs `unionVarSet` extra_tvs - ; when (any (`elemVarSet` env_tvs) sig_tvs) - (bleatEscapedTvs env_tvs sig_tvs sig_tvs) - } - -bleatEscapedTvs :: TcTyVarSet -- The global tvs - -> [TcTyVar] -- The possibly-escaping type variables - -> [TcTyVar] -- The zonked versions thereof - -> TcM () --- Complain about escaping type variables --- We pass a list of type variables, at least one of which --- escapes. The first list contains the original signature type variable, --- while the second contains the type variable it is unified to (usually itself) -bleatEscapedTvs globals sig_tvs zonked_tvs - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_tvs) = tidyOpenTyVars env0 sig_tvs - (env2, tidy_zonked_tvs) = tidyOpenTyVars env1 zonked_tvs - - ; (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs) - ; failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) } - where - main_msg = ptext (sLit "Inferred type is less polymorphic than expected") - - check (tidy_env, msgs) (sig_tv, zonked_tv) - | not (zonked_tv `elemVarSet` globals) = return (tidy_env, msgs) - | otherwise - = do { lcl_env <- getLclTypeEnv - ; (tidy_env1, globs) <- findGlobals (unitVarSet zonked_tv) lcl_env tidy_env - ; return (tidy_env1, escape_msg sig_tv zonked_tv globs : msgs) } - ------------------------ -escape_msg :: Var -> Var -> [SDoc] -> SDoc -escape_msg sig_tv zonked_tv globs - | notNull globs - = vcat [sep [msg, ptext (sLit "is mentioned in the environment:")], - nest 2 (vcat globs)] - | otherwise - = msg <+> ptext (sLit "escapes") - -- Sigh. It's really hard to give a good error message - -- all the time. One bad case is an existential pattern match. - -- We rely on the "When..." context to help. - where - msg = ptext (sLit "Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to - is_bound_to - | sig_tv == zonked_tv = empty - | otherwise = ptext (sLit "is unified with") <+> quotes (ppr zonked_tv) <+> ptext (sLit "which") --- \end{code} - -These two context are used with checkSigTyVars - -\begin{code} -sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType - -> TidyEnv -> TcM (TidyEnv, MsgDoc) -sigCtxt id sig_tvs sig_theta sig_tau tidy_env = do - actual_tau <- zonkTcType sig_tau - let - (env1, tidy_sig_tvs) = tidyOpenTyVars tidy_env sig_tvs - (env2, tidy_sig_rho) = tidyOpenType env1 (mkPhiTy sig_theta sig_tau) - (env3, tidy_actual_tau) = tidyOpenType env2 actual_tau - sub_msg = vcat [ptext (sLit "Signature type: ") <+> pprType (mkForAllTys tidy_sig_tvs tidy_sig_rho), - ptext (sLit "Type to generalise:") <+> pprType tidy_actual_tau - ] - msg = vcat [ptext (sLit "When trying to generalise the type inferred for") <+> quotes (ppr id), - nest 2 sub_msg] - - return (env3, msg) -\end{code} diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index e2308baa0d..169198c77a 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -404,7 +404,7 @@ ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ pprCo co1 <+> ppr_co TyConPrec co2 ppr_co p co@(ForAllCo {}) = ppr_forall_co p co ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) -ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos +ppr_co p (AxiomInstCo con cos) = angleBrackets (pprTypeNameApp p ppr_co (getName con) cos) ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ ppr_co FunPrec co1 @@ -504,7 +504,7 @@ coVarKind cv -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' mkCoercionType :: Type -> Type -> Type -mkCoercionType = curry mkPrimEqType +mkCoercionType = mkPrimEqPred isReflCo :: Coercion -> Bool isReflCo (Refl {}) = True diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 7df64c42d2..931bdf78ad 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -13,7 +13,7 @@ FamInstEnv: Type checked family instance declarations -- for details module FamInstEnv ( - FamInst(..), FamFlavor(..), famInstAxiom, famInstTyVars, + FamInst(..), FamFlavor(..), famInstAxiom, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, famInstLHS, pprFamInst, pprFamInstHdr, pprFamInsts, @@ -124,9 +124,6 @@ dataFamInstRepTyCon fi = case fi_flavor fi of DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) - -famInstTyVars :: FamInst -> TyVarSet -famInstTyVars = fi_tvs \end{code} \begin{code} @@ -158,7 +155,9 @@ pprFamInstHdr (FamInst {fi_axiom = axiom, fi_flavor = flavor}) | isTyConAssoc fam_tc = empty | otherwise = ptext (sLit "instance") - pprHead = pprTypeApp fam_tc tys + pprHead = sep [ ifPprDebug (ptext (sLit "forall") + <+> pprTvBndrs (coAxiomTyVars axiom)) + , pprTypeApp fam_tc tys ] pprTyConSort = case flavor of SynFamilyInst -> ptext (sLit "type") DataFamilyInst tycon @@ -415,6 +414,7 @@ lookupFamInstEnvConflicts envs fam_inst skol_tvs (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them + pprTrace "tcUnifyTys" (ppr tpl_tys $$ ppr match_tys $$ ppr fam_inst) $ case tcUnifyTys instanceBindFun tpl_tys match_tys of Just subst | conflicting old_fam_inst subst -> Just subst _other -> Nothing @@ -490,7 +490,7 @@ lookup_fam_inst_env' match_fun one_sided ie fam tys n_tys = length tys extra_tys = drop arity tys (match_tys, add_extra_tys) - | arity > n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) + | arity < n_tys = (take arity tys, \res_tys -> res_tys ++ extra_tys) | otherwise = (tys, \res_tys -> res_tys) -- The second case is the common one, hence functional representation diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 1e99775906..d2c49a1c74 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -8,7 +8,7 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - DFunId, OverlapFlag(..), + DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult, ClsInst(..), pprInstance, pprInstanceHdr, pprInstances, instanceHead, mkLocalInstance, mkImportedInstance, instanceDFunId, setInstanceDFunId, instanceRoughTcs, @@ -122,7 +122,8 @@ instanceDFunId = is_dfun setInstanceDFunId :: ClsInst -> DFunId -> ClsInst setInstanceDFunId ispec dfun - = ASSERT( idType dfun `eqType` idType (is_dfun ispec) ) + = ASSERT2( idType dfun `eqType` idType (is_dfun ispec) + , ppr dfun $$ ppr (idType dfun) $$ ppr (is_dfun ispec) $$ ppr (idType (is_dfun ispec)) ) -- We need to create the cached fields afresh from -- the new dfun id. In particular, the is_tvs in -- the ClsInst must match those in the dfun! @@ -432,6 +433,12 @@ type InstTypes = [Either TyVar Type] -- Left tv => Instantiate with any type of this tyvar's kind type InstMatch = (ClsInst, InstTypes) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , Bool) -- True if error condition caused by + -- SafeHaskell condition. \end{code} Note [InstTypes: instantiating types] @@ -535,12 +542,9 @@ lookupInstEnv' ie cls tys --------------- -- This is the common way to call this function. lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [ClsInst], -- These don't match but do unify - Bool) -- True if error condition caused by - -- SafeHaskell condition. - + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult + lookupInstEnv (pkg_ie, home_ie) cls tys = (safe_matches, all_unifs, safe_fail) where diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index e129cc60bc..c0364fa511 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -12,7 +12,7 @@ module Kind ( -- * Main data type - Kind, typeKind, + SuperKind, Kind, typeKind, -- Kinds anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, @@ -26,7 +26,7 @@ module Kind ( constraintKindTyCon, -- Super Kinds - tySuperKind, tySuperKindTyCon, + superKind, superKindTyCon, pprKind, pprParendKind, @@ -37,18 +37,18 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isUbxTupleKind, isArgTypeKind, isConstraintKind, - isConstraintOrLiftedKind, isKind, - isSuperKind, noHashInKind, + isConstraintOrLiftedKind, isKind, isKindVar, + isSuperKind, isSuperKindTyCon, isLiftedTypeKindCon, isConstraintKindCon, isAnyKind, isAnyKindCon, + okArrowArgKind, okArrowResultKind, - isSubArgTypeKind, tcIsSubArgTypeKind, - isSubOpenTypeKind, tcIsSubOpenTypeKind, - isSubKind, tcIsSubKind, defaultKind, - isSubKindCon, tcIsSubKindCon, isSubOpenTypeKindCon, + isSubArgTypeKind, isSubOpenTypeKind, + isSubKind, isSubKindCon, + tcIsSubKind, tcIsSubKindCon, + defaultKind, -- ** Functions on variables - isKiVar, splitKiTyVars, partitionKiTyVars, kiVarsOfKind, kiVarsOfKinds ) where @@ -60,38 +60,9 @@ import {-# SOURCE #-} Type ( typeKind, substKiWith, eqKind ) import TypeRep import TysPrim import TyCon -import Var import VarSet import PrelNames import Outputable - -import Data.List ( partition ) -\end{code} - -%************************************************************************ -%* * - Predicates over Kinds -%* * -%************************************************************************ - -\begin{code} -------------------- --- Lastly we need a few functions on Kinds - -isLiftedTypeKindCon :: TyCon -> Bool -isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey - --- This checks that its argument does not contain # or (#). --- It is used in tcTyVarBndrs. -noHashInKind :: Kind -> Bool -noHashInKind (TyVarTy {}) = True -noHashInKind (FunTy k1 k2) = noHashInKind k1 && noHashInKind k2 -noHashInKind (ForAllTy _ ki) = noHashInKind ki -noHashInKind (TyConApp kc kis) - = not (kc `hasKey` unliftedTypeKindTyConKey) - && not (kc `hasKey` ubxTupleKindTyConKey) - && all noHashInKind kis -noHashInKind _ = panic "noHashInKind" \end{code} %************************************************************************ @@ -140,37 +111,34 @@ isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon, tcIsSubArgTypeKindCon, - isSubOpenTypeKindCon, tcIsSubOpenTypeKindCon, isConstraintKindCon, - isAnyKindCon :: TyCon -> Bool + isUnliftedTypeKindCon, isSubArgTypeKindCon, + isSubOpenTypeKindCon, isConstraintKindCon, + isLiftedTypeKindCon, isAnyKindCon :: TyCon -> Bool + -isAnyKindCon tc = tyConUnique tc == anyKindTyConKey +isLiftedTypeKindCon tc = tyConUnique tc == liftedTypeKindTyConKey +isAnyKindCon tc = tyConUnique tc == anyKindTyConKey +isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey +isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey +isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey +isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey isAnyKind (TyConApp tc _) = isAnyKindCon tc isAnyKind _ = False -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey - isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc isOpenTypeKind _ = False -isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey - isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc isUbxTupleKind _ = False -isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey - isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc isArgTypeKind _ = False -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey - isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc isUnliftedTypeKind _ = False -isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey - isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False @@ -178,103 +146,121 @@ isConstraintOrLiftedKind (TyConApp tc _) = isConstraintKindCon tc || isLiftedTypeKindCon tc isConstraintOrLiftedKind _ = False --- Subkinding +-------------------------------------------- +-- Kinding for arrow (->) +-- Says when a kind is acceptable on lhs or rhs of an arrow +-- arg -> res + +okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool +okArrowArgKindCon kc + | isLiftedTypeKindCon kc = True + | isUnliftedTypeKindCon kc = True + | isConstraintKindCon kc = True + | otherwise = False + +okArrowResultKindCon kc + | okArrowArgKindCon kc = True + | isUbxTupleKindCon kc = True + | otherwise = False + +okArrowArgKind, okArrowResultKind :: Kind -> Bool +okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc +okArrowArgKind _ = False + +okArrowResultKind (TyConApp kc []) = okArrowResultKindCon kc +okArrowResultKind _ = False + +----------------------------------------- +-- Subkinding -- The tc variants are used during type-checking, where we don't want the -- Constraint kind to be a subkind of anything -- After type-checking (in core), Constraint is a subkind of argTypeKind -isSubOpenTypeKind, tcIsSubOpenTypeKind :: Kind -> Bool +isSubOpenTypeKind :: Kind -> Bool -- ^ True of any sub-kind of OpenTypeKind isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc isSubOpenTypeKind _ = False --- ^ True of any sub-kind of OpenTypeKind -tcIsSubOpenTypeKind (TyConApp kc []) = tcIsSubOpenTypeKindCon kc -tcIsSubOpenTypeKind _ = False - isSubOpenTypeKindCon kc - | isSubArgTypeKindCon kc = True - | isUbxTupleKindCon kc = True - | isOpenTypeKindCon kc = True - | otherwise = False - -tcIsSubOpenTypeKindCon kc - | tcIsSubArgTypeKindCon kc = True - | isUbxTupleKindCon kc = True - | isOpenTypeKindCon kc = True - | otherwise = False + = isSubArgTypeKindCon kc + || isUbxTupleKindCon kc + || isOpenTypeKindCon kc isSubArgTypeKindCon kc - | isUnliftedTypeKindCon kc = True - | isLiftedTypeKindCon kc = True - | isArgTypeKindCon kc = True - | isConstraintKindCon kc = True - | otherwise = False - -tcIsSubArgTypeKindCon kc - | isConstraintKindCon kc = False - | otherwise = isSubArgTypeKindCon kc - -isSubArgTypeKind, tcIsSubArgTypeKind :: Kind -> Bool + = isUnliftedTypeKindCon kc + || isLiftedTypeKindCon kc + || isArgTypeKindCon kc + || isConstraintKindCon kc -- Needed for error (Num a) "blah" + -- and so that (Ord a -> Eq a) is well-kinded + -- and so that (# Eq a, Ord b #) is well-kinded + +isSubArgTypeKind :: Kind -> Bool -- ^ True of any sub-kind of ArgTypeKind isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc isSubArgTypeKind _ = False -tcIsSubArgTypeKind (TyConApp kc []) = tcIsSubArgTypeKindCon kc -tcIsSubArgTypeKind _ = False - --- | Is this a super-kind (i.e. a type-of-kinds)? -isSuperKind :: Type -> Bool -isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc -isSuperKind _ = False - -- | Is this a kind (i.e. a type-of-types)? isKind :: Kind -> Bool isKind k = isSuperKind (typeKind k) -isSubKind, tcIsSubKind :: Kind -> Kind -> Bool -isSubKind = isSubKind' False -tcIsSubKind = isSubKind' True - --- The first argument denotes whether we are in the type-checking phase or not -isSubKind' :: Bool -> Kind -> Kind -> Bool +isSubKind :: Kind -> Kind -> Bool -- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ -isSubKind' duringTc (FunTy a1 r1) (FunTy a2 r2) - = (isSubKind' duringTc a2 a1) && (isSubKind' duringTc r1 r2) +isSuperKindTyCon :: TyCon -> Bool +isSuperKindTyCon tc = tc `hasKey` superKindTyConKey + +isSubKind (FunTy a1 r1) (FunTy a2 r2) + = (isSubKind a2 a1) && (isSubKind r1 r2) -isSubKind' duringTc k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) +isSubKind k1@(TyConApp kc1 k1s) k2@(TyConApp kc2 k2s) | isPromotedTypeTyCon kc1 || isPromotedTypeTyCon kc2 -- handles promoted kinds (List *, Nat, etc.) - = eqKind k1 k2 + = eqKind k1 k2 | isSuperKindTyCon kc1 || isSuperKindTyCon kc2 -- handles BOX - = WARN( not (isSuperKindTyCon kc2 && isSuperKindTyCon kc2 - && null k1s && null k2s), + = ASSERT2( isSuperKindTyCon kc2 && isSuperKindTyCon kc2 + && null k1s && null k2s, ppr kc1 <+> ppr kc2 ) - kc1 == kc2 + True -- If one is BOX, the other must be too | otherwise = -- handles usual kinds (*, #, (#), etc.) ASSERT2( null k1s && null k2s, ppr k1 <+> ppr k2 ) - if duringTc then kc1 `tcIsSubKindCon` kc2 - else kc1 `isSubKindCon` kc2 + kc1 `isSubKindCon` kc2 -isSubKind' _duringTc k1 k2 = eqKind k1 k2 +isSubKind k1 k2 = eqKind k1 k2 isSubKindCon :: TyCon -> TyCon -> Bool -- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ isSubKindCon kc1 kc2 - | kc1 == kc2 = True - | isSubArgTypeKindCon kc1 && isArgTypeKindCon kc2 = True - | isSubOpenTypeKindCon kc1 && isOpenTypeKindCon kc2 = True - | otherwise = False + | kc1 == kc2 = True + | isArgTypeKindCon kc2 = isSubArgTypeKindCon kc1 + | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 + | otherwise = False + +------------------------- +-- Hack alert: we need a tiny variant for the typechecker +-- Reason: f :: Int -> (a~b) +-- g :: forall (c::Constraint). Int -> c +-- We want to reject these, even though Constraint is +-- a sub-kind of OpenTypeKind. It must be a sub-kind of OpenTypeKind +-- *after* the typechecker +-- a) So that (Ord a -> Eq a) is a legal type +-- b) So that the simplifer can generate (error (Eq a) "urk") +-- +-- Easiest way to reject is simply to make Constraint not +-- below OpenTypeKind when type checking + +tcIsSubKind :: Kind -> Kind -> Bool +tcIsSubKind k1 k2 + | isConstraintKind k1 = isConstraintKind k2 + | otherwise = isSubKind k1 k2 tcIsSubKindCon :: TyCon -> TyCon -> Bool tcIsSubKindCon kc1 kc2 - | kc1 == kc2 = True - | isConstraintKindCon kc1 || isConstraintKindCon kc2 = False - | otherwise = isSubKindCon kc1 kc2 + | isConstraintKindCon kc1 = isConstraintKindCon kc2 + | otherwise = isSubKindCon kc1 kc2 +------------------------- defaultKind :: Kind -> Kind -- ^ Used when generalising: default OpenKind and ArgKind to *. -- See "Type#kind_subtyping" for more information on what that means @@ -291,21 +277,12 @@ defaultKind :: Kind -> Kind -- because that would allow a call like (f 3#) as well as (f True), -- and the calling conventions differ. -- This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k - | tcIsSubOpenTypeKind k = liftedTypeKind - | otherwise = k - -splitKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) --- Precondition: kind variables should precede type variables --- Postcondition: appending the two result lists gives the input! -splitKiTyVars = span (isSuperKind . tyVarKind) - -partitionKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) -partitionKiTyVars = partition (isSuperKind . tyVarKind) - --- Checks if this "type or kind" variable is a kind variable -isKiVar :: TyVar -> Bool -isKiVar v = isSuperKind (varType v) +-- +-- The test is really whether the kind is strictly above '*' +defaultKind (TyConApp kc _args) + | isOpenTypeKindCon kc = ASSERT( null _args ) liftedTypeKind + | isArgTypeKindCon kc = ASSERT( null _args ) liftedTypeKind +defaultKind k = k -- Returns the free kind variables in a kind kiVarsOfKind :: Kind -> VarSet diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index e2c192f435..05430920ce 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -6,88 +6,82 @@ The @TyCon@ datatype \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( -- * Main TyCon data types - TyCon, FieldLabel, + TyCon, FieldLabel, - AlgTyConRhs(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), + SynTyConRhs(..), - -- ** Coercion axiom constructors - CoAxiom(..), + -- ** Coercion axiom constructors + CoAxiom(..), coAxiomName, coAxiomArity, coAxiomTyVars, coAxiomLHS, coAxiomRHS, isImplicitCoAxiom, -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, + mkAlgTyCon, + mkClassTyCon, mkIParamTyCon, - mkFunTyCon, - mkPrimTyCon, - mkKindTyCon, - mkLiftedPrimTyCon, - mkTupleTyCon, - mkSynTyCon, - mkSuperKindTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSynTyCon, mkForeignTyCon, - mkPromotedDataTyCon, - mkPromotedTyCon, + mkPromotedDataTyCon, + mkPromotedTyCon, -- ** Predicates on TyCons isAlgTyCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isSynTyCon, isClosedSynTyCon, - isSuperKindTyCon, isDecomposableTyCon, - isForeignTyCon, tyConHasKind, + isDecomposableTyCon, + isForeignTyCon, isPromotedDataTyCon, isPromotedTypeTyCon, - isInjectiveTyCon, - isDataTyCon, isProductTyCon, isEnumerationTyCon, + isInjectiveTyCon, + isDataTyCon, isProductTyCon, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, isUnLiftedTyCon, - isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, - isTyConAssoc, tyConAssoc_maybe, - isRecursiveTyCon, - isImplicitTyCon, + isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, + isTyConAssoc, tyConAssoc_maybe, + isRecursiveTyCon, + isImplicitTyCon, -- ** Extracting information out of TyCons - tyConName, - tyConKind, - tyConUnique, - tyConTyVars, - tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, + tyConName, + tyConKind, + tyConUnique, + tyConTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, tyConParent, - tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, synTyConDefn, synTyConRhs, synTyConType, tyConExtName, -- External name for foreign types - algTyConRhs, - newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, + algTyConRhs, + newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, tupleTyConBoxity, tupleTyConSort, tupleTyConArity, -- ** Manipulating TyCons - tcExpandTyCon_maybe, coreExpandTyCon_maybe, - makeTyConAbstract, - newTyConCo, newTyConCo_maybe, + tcExpandTyCon_maybe, coreExpandTyCon_maybe, + makeTyConAbstract, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, -- * Primitive representations of Types - PrimRep(..), - tyConPrimRep, + PrimRep(..), + tyConPrimRep, primRepSizeW ) where @@ -100,6 +94,7 @@ import {-# SOURCE #-} IParam ( ipTyConName ) import Var import Class import BasicTypes +import ForeignCall import Name import PrelNames import Maybes @@ -112,7 +107,7 @@ import Data.Typeable (Typeable) \end{code} ----------------------------------------------- - Notes about type families + Notes about type families ----------------------------------------------- Note [Type synonym families] @@ -120,9 +115,9 @@ Note [Type synonym families] * Type synonym families, also known as "type functions", map directly onto the type functions in FC: - type family F a :: * - type instance F Int = Bool - ..etc... + type family F a :: * + type instance F Int = Bool + ..etc... * Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon @@ -133,15 +128,15 @@ Note [Type synonym families] family. * Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! + type instance F (F Int) = ... -- BAD! * Translation of type family decl: - type family F a :: * + type family F a :: * translates to a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon * Translation of type family decl: - type family F a :: * + type family F a :: * translates to a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon @@ -155,8 +150,8 @@ Note [Data type families] See also Note [Wrappers for data instance tycons] in MkId.lhs * Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool + data family T a :: * + data instance T Int = T1 | T2 Bool Here T is the "family TyCon". @@ -166,40 +161,40 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs * The user does not see any "equivalent types" as he did with type synonym families. He just sees constructors with types - T1 :: T Int - T2 :: Bool -> T Int + T1 :: T Int + T2 :: Bool -> T Int * Here's the FC version of the above declarations: - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~ R:TInt + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~ R:TInt The R:TInt is the "representation TyCons". It has an AlgTyConParent of - FamInstTyCon T [Int] ax_ti + FamInstTyCon T [Int] ax_ti -* The data contructor T2 has a wrapper (which is what the +* The data contructor T2 has a wrapper (which is what the source-level "T2" invokes): - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti * A data instance can declare a fully-fledged GADT: - data instance T (a,b) where + data instance T (a,b) where X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) + X2 :: a -> b -> T (a,b) Here's the FC version of the above declaration: - data R:TPair a where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~ R:TPair a b + data R:TPair a where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~ R:TPair a b - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) The R:TPair are the "representation TyCons". We have a bit of work to do, to unpick the result types of the @@ -208,24 +203,24 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs The representation TyCon R:TList, has an AlgTyConParent of - FamInstTyCon T [(a,b)] ax_pr + FamInstTyCon T [(a,b)] ax_pr * Notice that T is NOT translated to a FC type function; it just becomes a "data type" with no constructors, which can be coerced inot into R:TInt, R:TPair by the axioms. These axioms axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching + - use a data constructor + - do pattern matching Rather like newtype, in fact As a result - T behaves just like a data type so far as decomposition is concerned - - (T Int) is not implicitly converted to R:TInt during type inference. + - (T Int) is not implicitly converted to R:TInt during type inference. Indeed the latter type is unknown to the programmer. - - There *is* an instance for (T Int) in the type-family instance + - There *is* an instance for (T Int) in the type-family instance environment, but it is only used for overlap checking - It's fine to have T in the LHS of a type function: @@ -235,14 +230,14 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs should not think of a data family T as a *type function* at all, not even an injective one! We can't allow even injective type functions on the LHS of a type function: - type family injective G a :: * - type instance F (G Int) = Bool + type family injective G a :: * + type instance F (G Int) = Bool is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char + type instance G Int = Bool + type instance F Bool = Char So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. + data type with some axioms that connect it to other data types. Note [Associated families and their parent class] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -250,18 +245,18 @@ Note [Associated families and their parent class] that they have a TyConParent of AssocFamilyTyCon, which identifies the parent class. -However there is an important sharing relationship between +However there is an important sharing relationship between * the tyConTyVars of the parent Class * the tyConTyvars of the associated TyCon class C a b where data T p a - type F a q b + type F a q b Here the 'a' and 'b' are shared with the 'Class'; that is, they have the same Unique. - -This is important. In an instance declaration we expect + +This is important. In an instance declaration we expect * all the shared variables to be instantiated the same way * the non-shared variables of the associated type should not be instantiated at all @@ -271,9 +266,9 @@ This is important. In an instance declaration we expect type F [x] q (Tree y) = (x,y,q) %************************************************************************ -%* * +%* * \subsection{The data type} -%* * +%* * %************************************************************************ \begin{code} @@ -292,78 +287,81 @@ This is important. In an instance declaration we expect data TyCon = -- | The function type constructor, @(->)@ FunTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity } -- | Algebraic type constructors, which are defined to be those -- arising @data@ type and @newtype@ declarations. All these -- constructors are lifted and boxed. See 'AlgTyConRhs' for more -- information. - | AlgTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, + | AlgTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, - tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. + tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the type constructor. -- Invariant: length tyvars = arity - -- Precisely, this list scopes over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in 'algTyConRhs.NewTyCon' - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data constructors. - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? - -- If so, that doesn't mean it's a true GADT; - -- only that the "where" form was used. + -- Precisely, this list scopes over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in 'algTyConRhs.NewTyCon' + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data constructors. + tyConCType :: Maybe CType, -- The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? + -- If so, that doesn't mean it's a true GADT; + -- only that the "where" form was used. -- This field is used only to guide pretty-printing - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type -- (always empty for GADTs). - -- A \"stupid theta\" is the context to the left - -- of an algebraic type declaration, - -- e.g. @Eq a@ in the declaration + -- A \"stupid theta\" is the context to the left + -- of an algebraic type declaration, + -- e.g. @Eq a@ in the declaration -- @data Eq a => T a ...@. - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the -- data constructors of the algebraic type - algTcRec :: RecFlag, -- ^ Tells us whether the data type is part + algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - - algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' - -- for derived 'TyCon's representing class - -- or family instances, respectively. + + algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' + -- for derived 'TyCon's representing class + -- or family instances, respectively. -- See also 'synTcParent' } - -- | Represents the infinite family of tuple type constructors, + -- | Represents the infinite family of tuple type constructors, -- @()@, @(a,b)@, @(# a, b #)@ etc. | TupleTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, - tyConTupleSort :: TupleSort, - tyConTyVars :: [TyVar], - dataCon :: DataCon -- ^ Corresponding tuple data constructor + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, + tyConTupleSort :: TupleSort, + tyConTyVars :: [TyVar], + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms | SynTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, - tyConTyVars :: [TyVar], -- Bound tyvars + tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: SynTyConRhs, -- ^ Contains information about the + synTcRhs :: SynTyConRhs, -- ^ Contains information about the -- expansion of the synonym synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' @@ -374,53 +372,41 @@ data TyCon -- | Primitive types; cannot be defined in Haskell. This includes -- the usual suspects (such as @Int#@) as well as foreign-imported -- types and kinds - | PrimTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tc_kind :: Kind, - tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance - -- of the arity of a primtycon is! - - primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are - -- boxed (represented by pointers). This 'PrimRep' - -- holds that information. - -- Only relevant if tc_kind = * - - isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted + | PrimTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tc_kind :: Kind, + tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance + -- of the arity of a primtycon is! + + primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are + -- boxed (represented by pointers). This 'PrimRep' + -- holds that information. + -- Only relevant if tc_kind = * + + isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted -- (may not contain bottom) - -- but foreign-imported ones may be lifted + -- but foreign-imported ones may be lifted - tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, + tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, -- holds the name of the imported thing } - -- | Super-kinds. These are "kinds-of-kinds" and are never seen in - -- Haskell source programs. There are only two super-kinds: TY (aka - -- "box"), which is the super-kind of kinds that construct types - -- eventually, and CO (aka "diamond"), which is the super-kind of - -- kinds that just represent coercions. - -- - -- Super-kinds have no kind themselves, and have arity zero - | SuperKindTyCon { - tyConUnique :: Unique, - tyConName :: Name - } - -- | Represents promoted data constructor. - | 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 + | 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 } -- | Represents promoted type constructor. | PromotedTypeTyCon { - 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 + 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 TysPrim.superKind ty_con :: TyCon -- ^ Corresponding type constructor } @@ -436,14 +422,14 @@ data AlgTyConRhs -- it's represented by a pointer. Used when we export a data type -- abstractly into an .hi file. = AbstractTyCon - Bool -- True <=> It's definitely a distinct data type, - -- equal only to itself; ie not a newtype - -- False <=> Not sure - -- See Note [AbstractTyCon and type equality] + Bool -- True <=> It's definitely a distinct data type, + -- equal only to itself; ie not a newtype + -- False <=> Not sure + -- See Note [AbstractTyCon and type equality] -- | Represents an open type family without a fixed right hand -- side. Additional instances can appear at any time. - -- + -- -- These are introduced by either a top level declaration: -- -- > data T a :: * @@ -458,42 +444,42 @@ data AlgTyConRhs -- declaration. This includes data types with no constructors at -- all. | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the user - -- declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' tag - -- (see the tag assignment in DataCon.mkDataCon) - - is_enum :: Bool -- ^ Cached value: is this an enumeration type? + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the user + -- declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' tag + -- (see the tag assignment in DataCon.mkDataCon) + + is_enum :: Bool -- ^ Cached value: is this an enumeration type? -- See Note [Enumeration types] } -- | Information about those 'TyCon's derived from a @newtype@ declaration | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. -- It has no existentials - nt_rhs :: Type, -- ^ Cached value: the argument type of the constructor, - -- which is just the representation type of the 'TyCon' - -- (remember that @newtype@s do not exist at runtime + nt_rhs :: Type, -- ^ Cached value: the argument type of the constructor, + -- which is just the representation type of the 'TyCon' + -- (remember that @newtype@s do not exist at runtime -- so need a different representation type). - -- - -- The free 'TyVar's of this type are the 'tyConTyVars' + -- + -- The free 'TyVar's of this type are the 'tyConTyVars' -- from the corresponding 'TyCon' - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from -- the representation 'Type'. - + -- See Note [Newtype coercions] -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] + -- See Note [Newtype eta] -- Watch out! If any newtypes become transparent -- again check Trac #1072. } @@ -509,62 +495,62 @@ TODO -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons DataFamilyTyCon {} = [] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons DataFamilyTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] -- ^ Both type classes as well as family instances imply implicit -- type constructors. These implicit type constructors refer to their parent -- structure (ie, the class or family from which they derive) using a type of --- the following form. We use 'TyConParent' for both algebraic and synonym +-- the following form. We use 'TyConParent' for both algebraic and synonym -- types, but the variant 'ClassTyCon' will only be used by algebraic 'TyCon's. -data TyConParent +data TyConParent = -- | An ordinary type constructor has no parent. NoParentTyCon -- | Type constructors representing a class dictionary. -- See Note [ATyCon for classes] in TypeRep | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the current tycon + Class -- INVARIANT: the classTyCon of this Class is the current tycon -- | Associated type of a implicit parameter. | IPTyCon (IPName Name) - -- | An *associated* type of a class. - | AssocFamilyTyCon - Class -- The class in whose declaration the family is declared - -- See Note [Associated families and their parent class] + -- | An *associated* type of a class. + | AssocFamilyTyCon + 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 *data* family. Parameters: -- -- 1) The type family in question -- -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: + -- of the current 'TyCon' (not the family one). INVARIANT: -- the number of types matches the arity of the family 'TyCon' -- -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family - | FamInstTyCon -- See Note [Data type families] + | FamInstTyCon -- See Note [Data type families] CoAxiom -- The coercion constructor, -- always of kind T ty1 ty2 ~ R:T a b c - -- where T is the family TyCon, + -- 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 + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- Match in length the tyConTyVars of the family TyCon - -- E.g. data intance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcParent = FamInstTyCon T [a] co + -- E.g. data intance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = FamInstTyCon T [a] co instance Outputable TyConParent where ppr NoParentTyCon = text "No parent" @@ -590,9 +576,9 @@ isNoParent _ = False -- | Information pertaining to the expansion of a type synonym (@type@) data SynTyConRhs = -- | An ordinary type synonyn. - SynonymTyCon - Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. - -- It acts as a template for the expansion when the 'TyCon' + SynonymTyCon + Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + -- It acts as a template for the expansion when the 'TyCon' -- is applied to some types. -- | A type synonym family e.g. @type family F x y :: * -> *@ @@ -614,17 +600,17 @@ via the PromotedDataTyCon alternative in TyCon. * The *kind* of a promoted DataCon may be polymorphic. Example: type of DataCon Just :: forall (a:*). a -> Maybe a kind of (promoted) tycon Just :: forall (a:box). a -> Maybe a - The kind is not identical to the type, because of the */box + The kind is not identical to the type, because of the */box kind signature on the forall'd variable; so the tc_kind field of - PromotedDataTyCon is not identical to the dataConUserType of the + PromotedDataTyCon is not identical to the dataConUserType of the DataCon. But it's the same modulo changing the variable kinds, - done by Kind.promoteType. + done by Kind.promoteType. * Small note: We promote the *user* type of the DataCon. Eg data T = MkT {-# UNPACK #-} !(Bool, Bool) The promoted kind is MkT :: (Bool,Bool) -> T - *not* + *not* MkT :: Bool -> Bool -> T Note [Enumeration types] @@ -655,7 +641,7 @@ example, newtype T a = MkT (a -> a) -the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. +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 @@ -667,54 +653,54 @@ 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 - axiom CoT : (forall t. T t) ~ (forall t. [t]) + axiom CoT : (forall t. T t) ~ (forall t. [t]) and then when we used CoT at a particular type, s, we'd say - CoT @ s + CoT @ s which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider - newtype Parser m a = MkParser (Foogle m a) + newtype Parser m a = MkParser (Foogle m a) Are these two types equal (to Core)? - Monad (Parser m) - Monad (Foogle m) + Monad (Parser m) + Monad (Foogle m) Well, yes. But to see that easily we eta-reduce the RHS type of Parser, in this case to ([], Froogle), so that even unsaturated applications -of Parser will work right. This eta reduction is done when the type +of Parser will work right. This eta reduction is done when the type constructor is built, and cached in NewTyCon. The cached field is only used in coreExpandTyCon_maybe. - + Here's an example that I think showed up in practice Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) After desugaring, and discarding the data constructors for the newtypes, we get: - w2 :: Foo T - w2 = w1 + w2 :: Foo T + w2 = w1 And now Lint complains unless Foo T == Foo [], and that requires T==[] This point carries over to the newtype coercion, because we need to -say - w2 = w1 `cast` Foo CoT +say + w2 = w1 `cast` Foo CoT -so the coercion tycon CoT must have - kind: T ~ [] - and arity: 0 +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 %************************************************************************ -%* * +%* * Coercion axioms -%* * +%* * %************************************************************************ \begin{code} @@ -723,7 +709,7 @@ 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_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" @@ -761,9 +747,9 @@ See also Note [Implicit TyThings] in HscTypes %************************************************************************ -%* * +%* * \subsection{PrimRep} -%* * +%* * %************************************************************************ A PrimRep is somewhat similar to a CgRep (see codeGen/SMRep) and a @@ -787,11 +773,11 @@ and clearly defined purpose: data PrimRep = VoidRep | PtrRep - | IntRep -- ^ Signed, word-sized value - | WordRep -- ^ Unsigned, word-sized value - | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) - | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'PtrRep') + | IntRep -- ^ Signed, word-sized value + | WordRep -- ^ Unsigned, word-sized value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'PtrRep') | FloatRep | DoubleRep deriving( Eq, Show ) @@ -813,9 +799,9 @@ primRepSizeW VoidRep = 0 \end{code} %************************************************************************ -%* * +%* * \subsection{TyCon Construction} -%* * +%* * %************************************************************************ Note: the TyCon constructors all take a Kind as one argument, even though @@ -826,15 +812,15 @@ So we compromise, and move their Kind calculation to the call site. \begin{code} -- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want +-- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want -- this functionality mkFunTyCon :: Name -> Kind -> TyCon -mkFunTyCon name kind - = FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tc_kind = kind, - tyConArity = 2 +mkFunTyCon name kind + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tc_kind = kind, + tyConArity = 2 } -- | This is the making of an algebraic 'TyCon'. Notably, you have to @@ -843,86 +829,89 @@ mkFunTyCon name kind -- module) mkAlgTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. -- Arity is inferred from the length of this list + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' -> AlgTyConRhs -- ^ Information about dat aconstructors -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn - = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, - algTcRec = is_rec, - algTcGadtSyntax = gadt_syn +mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcRec = is_rec, + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon mkClassTyCon name kind tyvars rhs clas is_rec = - mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False + mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) is_rec False -- | Simpler specialization of 'mkAlgTyCon' for implicit paramaters mkIParamTyCon :: Name -> Kind -> TyVar -> AlgTyConRhs -> RecFlag -> TyCon mkIParamTyCon name kind tyvar rhs is_rec = - mkAlgTyCon name kind [tyvar] [] rhs NoParentTyCon is_rec False + mkAlgTyCon name kind [tyvar] Nothing [] rhs NoParentTyCon is_rec False -mkTupleTyCon :: Name +mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' -> Arity -- ^ Arity of the tuple -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> DataCon + -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> TyCon mkTupleTyCon name kind arity tyvars con sort = TupleTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tc_kind = kind, - tyConArity = arity, - tyConTupleSort = sort, - tyConTyVars = tyvars, - dataCon = con + tyConUnique = nameUnique name, + tyConName = name, + tc_kind = kind, + tyConArity = arity, + tyConTupleSort = sort, + tyConTyVars = tyvars, + dataCon = con } -- ^ Foreign-imported (.NET) type constructors are represented -- as primitive, but /lifted/, 'TyCons' for now. They are lifted -- because the Haskell type @T@ representing the (foreign) .NET -- type @T@ is actually implemented (in ILX) as a @thunk<T>@ -mkForeignTyCon :: Name +mkForeignTyCon :: Name -> Maybe FastString -- ^ Name of the foreign imported thing, maybe - -> Kind - -> Arity + -> Kind + -> Arity -> TyCon mkForeignTyCon name ext_name kind arity = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = arity, - primTyConRep = PtrRep, -- they all do - isUnLifted = False, - tyConExtName = ext_name + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = arity, + primTyConRep = PtrRep, -- they all do + isUnLifted = False, + tyConExtName = ext_name } -- | Create an unlifted primitive 'TyCon', such as @Int#@ mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon mkPrimTyCon name kind arity rep - = mkPrimTyCon' name kind arity rep True + = mkPrimTyCon' name kind arity rep True -- | Kind constructors mkKindTyCon :: Name -> Kind -> TyCon mkKindTyCon name kind - = mkPrimTyCon' name kind 0 VoidRep True + = mkPrimTyCon' name kind 0 VoidRep True -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon @@ -932,38 +921,30 @@ mkLiftedPrimTyCon name kind arity rep mkPrimTyCon' :: Name -> Kind -> Arity -> PrimRep -> Bool -> TyCon mkPrimTyCon' name kind arity rep is_unlifted = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = arity, - primTyConRep = rep, - isUnLifted = is_unlifted, - tyConExtName = Nothing + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = arity, + primTyConRep = rep, + isUnLifted = is_unlifted, + tyConExtName = Nothing } -- | Create a type synonym 'TyCon' mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs -> TyConParent -> TyCon mkSynTyCon name kind tyvars rhs parent - = SynTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tc_kind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - synTcRhs = rhs, + = SynTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tc_kind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + synTcRhs = rhs, synTcParent = parent } --- | Create a super-kind 'TyCon' -mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero -mkSuperKindTyCon name - = SuperKindTyCon { - tyConName = name, - tyConUnique = nameUnique name - } - -- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name +-- 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 @@ -976,7 +957,7 @@ mkPromotedDataTyCon con name unique kind arity } -- | Create a promoted type constructor 'TyCon' --- Somewhat dodgily, we give it the same Name +-- Somewhat dodgily, we give it the same Name -- as the type constructor itself mkPromotedTyCon :: TyCon -> Kind -> TyCon mkPromotedTyCon tc kind @@ -1001,7 +982,7 @@ isAbstractTyCon _ = False -- | Make an algebraic 'TyCon' abstract. Panics if the supplied 'TyCon' is not algebraic makeTyConAbstract :: TyCon -> TyCon -makeTyConAbstract tc@(AlgTyCon { algTcRhs = rhs }) +makeTyConAbstract tc@(AlgTyCon { algTcRhs = rhs }) = tc { algTcRhs = AbstractTyCon (isDistinctAlgRhs rhs) } makeTyConAbstract tc = pprPanic "makeTyConAbstract" (ppr tc) @@ -1015,7 +996,7 @@ isPrimTyCon _ = False isUnLiftedTyCon :: TyCon -> Bool isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted isUnLiftedTyCon (TupleTyCon {tyConTupleSort = sort}) = not (isBoxed (tupleSortBoxity sort)) -isUnLiftedTyCon _ = False +isUnLiftedTyCon _ = False -- | Returns @True@ if the supplied 'TyCon' resulted from either a -- @data@ or @newtype@ declaration @@ -1025,30 +1006,30 @@ isAlgTyCon (TupleTyCon {}) = True isAlgTyCon _ = False isDataTyCon :: TyCon -> Bool --- ^ Returns @True@ for data types that are /definitely/ represented by --- heap-allocated constructors. These are scrutinised by Core-level +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level -- @case@ expressions, and they get info tables allocated for them. --- +-- -- Generally, the function will be true for all @data@ types and false -- for @newtype@s, unboxed tuples and type family 'TyCon's. But it is -- not guaranteed to return @True@ in all cases that it could. --- +-- -- NB: for a data type family, only the /instance/ 'TyCon's -- get an info table. The family declaration 'TyCon' does not isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of DataFamilyTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) isDataTyCon _ = False --- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to +-- | 'isDistinctTyCon' is true of 'TyCon's that are equal only to -- themselves, even via coercions (except for unsafeCoerce). -- This excludes newtypes, type functions, type synonyms. --- It relates directly to the FC consistency story: --- If the axioms are consistent, +-- It relates directly to the FC consistency story: +-- If the axioms are consistent, -- and co : S tys ~ T tys, and S,T are "distinct" TyCons, -- then S=T. -- Cf Note [Pruning dead case alternatives] in Unify @@ -1061,7 +1042,7 @@ isDistinctTyCon (PromotedDataTyCon {}) = True isDistinctTyCon _ = False isDistinctAlgRhs :: AlgTyConRhs -> Bool -isDistinctAlgRhs (DataTyCon {}) = True +isDistinctAlgRhs (DataTyCon {}) = True isDistinctAlgRhs (DataFamilyTyCon {}) = True isDistinctAlgRhs (AbstractTyCon distinct) = distinct isDistinctAlgRhs (NewTyCon {}) = False @@ -1075,33 +1056,33 @@ isNewTyCon _ = False -- into, and (possibly) a coercion from the representation type to the @newtype@. -- Returns @Nothing@ if this is not possible. unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) unwrapNewTyCon_maybe _ = Nothing isProductTyCon :: TyCon -> Bool -- | A /product/ 'TyCon' must both: -- -- 1. Have /one/ constructor --- +-- -- 2. /Not/ be existential --- --- However other than this there are few restrictions: they may be @data@ or @newtype@ +-- +-- However other than this there are few restrictions: they may be @data@ or @newtype@ -- 'TyCon's of any boxity and may even be recursive. isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of - DataTyCon{ data_cons = [data_con] } - -> isVanillaDataCon data_con - NewTyCon {} -> True - _ -> False -isProductTyCon (TupleTyCon {}) = True + DataTyCon{ data_cons = [data_con] } + -> isVanillaDataCon data_con + NewTyCon {} -> True + _ -> False +isProductTyCon (TupleTyCon {}) = True isProductTyCon _ = False -- | Is this a 'TyCon' representing a type synonym (@type@)? isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True -isSynTyCon _ = False +isSynTyCon _ = False -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique @@ -1130,7 +1111,7 @@ isEnumerationTyCon _ = False isFamilyTyCon :: TyCon -> Bool isFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True -isFamilyTyCon _ = False +isFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? isSynFamilyTyCon :: TyCon -> Bool @@ -1150,12 +1131,12 @@ isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon) -- T ty1 ~ T ty2 => ty1 ~ ty2 isInjectiveTyCon :: TyCon -> Bool isInjectiveTyCon tc = not (isSynTyCon tc) - -- Ultimately we may have injective associated types + -- Ultimately we may have injective associated types -- in which case this test will become more interesting - -- + -- -- It'd be unusual to call isInjectiveTyCon on a regular H98 - -- type synonym, because you should probably have expanded it first - -- But regardless, it's not injective! + -- type synonym, because you should probably have expanded it first + -- But regardless, it's not injective! -- | Are we able to extract informationa 'TyVar' to class argument list -- mappping from a given 'TyCon'? @@ -1215,11 +1196,6 @@ isForeignTyCon :: TyCon -> Bool isForeignTyCon (PrimTyCon {tyConExtName = Just _}) = True isForeignTyCon _ = False --- | Is this a super-kind 'TyCon'? -isSuperKindTyCon :: TyCon -> Bool -isSuperKindTyCon (SuperKindTyCon {}) = True -isSuperKindTyCon _ = False - -- | Is this a PromotedDataTyCon? isPromotedDataTyCon :: TyCon -> Bool isPromotedDataTyCon (PromotedDataTyCon {}) = True @@ -1237,58 +1213,62 @@ isPromotedTypeTyCon _ = False -- Note that: -- -- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and +-- the class declaration in which they reside, and -- -- * 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 +isImplicitTyCon tycon | isTyConAssoc tycon = True | isSynTyCon tycon = False | isAlgTyCon tycon = isTupleTyCon tycon | otherwise = True - -- 'otherwise' catches: FunTyCon, PrimTyCon, - -- PromotedDataCon, PomotedTypeTyCon, SuperKindTyCon + -- 'otherwise' catches: FunTyCon, PrimTyCon, + -- PromotedDataCon, PomotedTypeTyCon + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing \end{code} ----------------------------------------------- --- Expand type-constructor applications +-- Expand type-constructor applications ----------------------------------------------- \begin{code} -tcExpandTyCon_maybe, coreExpandTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body type +tcExpandTyCon_maybe, coreExpandTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body type -- of the synonym (not yet substituted) and any arguments -- remaining from the application --- ^ Used to create the view the /typechecker/ has on 'TyCon's. +-- ^ Used to create the view the /typechecker/ has on 'TyCon's. -- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' -tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, - synTcRhs = SynonymTyCon rhs }) tys +tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, + synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys tcExpandTyCon_maybe _ _ = Nothing --------------- --- ^ Used to create the view /Core/ has on 'TyCon's. We expand +-- ^ Used to create the view /Core/ has on 'TyCon's. We expand -- not only closed synonyms like 'tcExpandTyCon_maybe', -- but also non-recursive @newtype@s coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys ---------------- -expand :: [TyVar] -> Type -- Template - -> [a] -- Args - -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion +expand :: [TyVar] -> Type -- Template + -> [a] -- Args + -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion expand tvs rhs tys = case n_tvs `compare` length tys of - LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) - EQ -> Just (tvs `zip` tys, rhs, []) + LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) + EQ -> Just (tvs `zip` tys, rhs, []) GT -> Nothing where n_tvs = length tvs @@ -1296,12 +1276,7 @@ expand tvs rhs tys \begin{code} tyConKind :: TyCon -> Kind -tyConKind (SuperKindTyCon {}) = pprPanic "tyConKind" empty -tyConKind tc = tc_kind tc - -tyConHasKind :: TyCon -> Bool -tyConHasKind (SuperKindTyCon {}) = False -tyConHasKind _ = True +tyConKind = tc_kind -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors -- could be found @@ -1315,17 +1290,17 @@ tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = cons }}) = Just cons tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just [con] -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] tyConDataCons_maybe _ = Nothing -- | Determine the number of value constructors a 'TyCon' has. Panics if the 'TyCon' -- is not algebraic or a tuple tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon {data_cons = cons}}) = length cons tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon {}}) = 1 tyConFamilySize (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = 0 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple @@ -1355,11 +1330,11 @@ newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) -- is not a @newtype@, returns @Nothing@ newTyConCo_maybe :: TyCon -> Maybe CoAxiom newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing +newTyConCo_maybe _ = Nothing newTyConCo :: TyCon -> CoAxiom newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co + Just co -> co Nothing -> pprPanic "newTyConCo" (ppr tc) -- | Find the primitive representation of a 'TyCon' @@ -1373,7 +1348,7 @@ tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep -- an algebraic type declaration, e.g. @Eq a@ in the declaration @data Eq a => T a ...@ tyConStupidTheta :: TyCon -> [PredType] tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta (TupleTyCon {}) = [] +tyConStupidTheta (TupleTyCon {}) = [] tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} @@ -1381,7 +1356,7 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) -- | Extract the 'TyVar's bound by a type synonym and the corresponding (unsubstituted) right hand side. -- If the given 'TyCon' is not a type synonym, panics synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) +synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) = (tyvars, ty) synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) @@ -1389,15 +1364,15 @@ synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) -- if the given 'TyCon' is not a type synonym synTyConRhs :: TyCon -> SynTyConRhs synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs -synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) +synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) -- | Find the expansion of the type synonym represented by the given 'TyCon'. The free variables of this -- type will typically include those 'TyVar's bound by the 'TyCon'. Panics if the 'TyCon' is not that of -- a type synonym synTyConType :: TyCon -> Type synTyConType tc = case synTcRhs tc of - SynonymTyCon t -> t - _ -> pprPanic "synTyConType" (ppr tc) + SynonymTyCon t -> t + _ -> pprPanic "synTyConType" (ppr tc) \end{code} \begin{code} @@ -1406,10 +1381,10 @@ synTyConType tc = case synTcRhs tc of -- has more than one constructor, or represents a primitive or function type constructor then -- @Nothing@ is returned. In any other case, the function panics tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) = Just c +tyConSingleDataCon_maybe (TupleTyCon {dataCon = c}) = Just c tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = DataTyCon { data_cons = [c] }}) = Just c tyConSingleDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = c }}) = Just c -tyConSingleDataCon_maybe _ = Nothing +tyConSingleDataCon_maybe _ = Nothing \end{code} \begin{code} @@ -1462,7 +1437,7 @@ tyConFamInst_maybe tc FamInstTyCon _ f ts -> Just (f, ts) _ -> Nothing --- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents +-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents -- a coercion identifying the representation type with the type instance family. -- Otherwise, return @Nothing@ tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom @@ -1474,9 +1449,9 @@ tyConFamilyCoercion_maybe tc %************************************************************************ -%* * +%* * \subsection[TyCon-instances]{Instance declarations for @TyCon@} -%* * +%* * %************************************************************************ @TyCon@s are compared by comparing their @Unique@s. @@ -1491,16 +1466,23 @@ instance Eq TyCon where instance Ord TyCon where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } compare a b = getUnique a `compare` getUnique b instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr tc = ppr (tyConName tc) + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) + +pprPromotionQuote :: TyCon -> SDoc +pprPromotionQuote (PromotedTypeTyCon {}) = char '\'' +pprPromotionQuote (PromotedDataTyCon {}) = char '\'' +pprPromotionQuote _ = empty instance NamedThing TyCon where getName = tyConName @@ -1515,13 +1497,13 @@ instance Data.Data TyCon where instance Eq CoAxiom where a == b = case (a `compare` b) of { EQ -> True; _ -> False } a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - + instance Ord CoAxiom where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = getUnique a `compare` getUnique b + compare a b = getUnique a `compare` getUnique b instance Uniquable CoAxiom where getUnique = co_ax_unique diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 69e91b5975..fe913d48e7 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -27,7 +27,7 @@ module Type ( -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, - mkAppTy, mkAppTys, splitAppTy, splitAppTys, + mkAppTy, mkAppTys, mkNakedAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, @@ -51,11 +51,11 @@ module Type ( -- Pred types mkFamilyTyConApp, isDictLikeTy, - mkEqPred, mkClassPred, + mkNakedEqPred, mkEqPred, mkPrimEqPred, + mkClassPred, mkIPPred, noParenPred, isClassPred, isEqPred, isIPPred, - mkPrimEqType, - + -- Deconstructing predicate types PredTree(..), predTreePredType, classifyPredType, getClassPredTys, getClassPredTys_maybe, @@ -66,6 +66,7 @@ module Type ( funTyCon, -- ** Predicates on types + isTypeVar, isKindVar, isTyVarTy, isFunTy, isDictTy, isPredTy, isKindTy, -- (Lifting and boxity) @@ -82,7 +83,7 @@ module Type ( -- ** Common Kinds and SuperKinds anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, constraintKind, - tySuperKind, + superKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, @@ -92,7 +93,7 @@ module Type ( -- * Type free variables tyVarsOfType, tyVarsOfTypes, expandTypeSynonyms, - typeSize, varSetElemsKvsFirst, sortQuantVars, + typeSize, varSetElemsKvsFirst, -- * Type comparison eqType, eqTypeX, eqTypes, cmpType, cmpTypes, @@ -133,7 +134,8 @@ module Type ( substKiWith, substKisWith, -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, + pprTvBndr, pprTvBndrs, pprForAll, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, ) where @@ -168,6 +170,7 @@ import Util import Outputable import FastString +import Data.List ( partition ) import Maybes ( orElse ) import Data.Maybe ( isJust ) @@ -328,11 +331,8 @@ invariant: use it. \begin{code} -- | Applies a type to another, as in e.g. @k a@ mkAppTy :: Type -> Type -> Type -mkAppTy orig_ty1 orig_ty2 - = mk_app orig_ty1 - where - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app _ = AppTy orig_ty1 orig_ty2 +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 -- Note that the TyConApp could be an -- under-saturated type synonym. GHC allows that; e.g. -- type Foo k = k a -> k a @@ -343,18 +343,14 @@ mkAppTy orig_ty1 orig_ty2 -- but once the type synonyms are expanded all is well mkAppTys :: Type -> [Type] -> Type -mkAppTys orig_ty1 [] = orig_ty1 - -- This check for an empty list of type arguments - -- avoids the needless loss of a type synonym constructor. - -- For example: mkAppTys Rational [] - -- returns to (Ratio Integer), which has needlessly lost - -- the Rational part. -mkAppTys orig_ty1 orig_tys2 - = mk_app orig_ty1 - where - mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - -- mkTyConApp: see notes with mkAppTy - mk_app _ = foldl AppTy orig_ty1 orig_tys2 +mkAppTys ty1 [] = ty1 +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +mkNakedAppTys :: Type -> [Type] -> Type +mkNakedAppTys ty1 [] = ty1 +mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) +mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 ------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) @@ -503,6 +499,16 @@ funArgTy ty = pprPanic "funArgTy" (ppr ty) ~~~~~~~~ \begin{code} +-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | otherwise + = TyConApp tycon tys + -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -714,8 +720,8 @@ mkPiKinds :: [TyVar] -> Kind -> Kind -- returns forall k1 k2. (k1 -> *) -> k2 mkPiKinds [] res = res mkPiKinds (tv:tvs) res - | isKiVar tv = ForAllTy tv (mkPiKinds tvs res) - | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) + | isKindVar tv = ForAllTy tv (mkPiKinds tvs res) + | otherwise = FunTy (tyVarKind tv) (mkPiKinds tvs res) mkPiType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or a forall type, depending @@ -855,21 +861,26 @@ Make PredTypes --------------------- Equality types --------------------------------- \begin{code} -- | Creates a type equality predicate -mkEqPred :: (Type, Type) -> PredType -mkEqPred (ty1, ty2) - -- IA0_TODO: The caller should give the kind. - = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) +mkNakedEqPred :: Kind -> Type -> Type -> PredType +mkNakedEqPred k ty1 ty2 + = WARN( not (typeKind ty1 `isSubKind` k) || not (typeKind ty2 `isSubKind` k), + ppr k $$ (ppr ty1 <+> dcolon <+> ppr (typeKind ty1)) + $$ (ppr ty2 <+> dcolon <+> ppr (typeKind ty2)) ) TyConApp eqTyCon [k, ty1, ty2] - where k = defaultKind (typeKind ty1) --- where k = typeKind ty1 -mkPrimEqType :: (Type, Type) -> Type -mkPrimEqType (ty1, ty2) - -- IA0_TODO: The caller should give the kind. - = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) +mkEqPred :: Type -> Type -> PredType +mkEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) + TyConApp eqTyCon [k, ty1, ty2] + where + k = typeKind ty1 + +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) TyConApp eqPrimTyCon [k, ty1, ty2] - where k = defaultKind (typeKind ty1) --- where k = typeKind ty1 + where + k = typeKind ty1 \end{code} --------------------- Implicit parameters --------------------------------- @@ -937,7 +948,7 @@ data PredTree = ClassPred Class [Type] predTreePredType :: PredTree -> PredType predTreePredType (ClassPred clas tys) = mkClassPred clas tys -predTreePredType (EqPred ty1 ty2) = mkEqPred (ty1, ty2) +predTreePredType (EqPred ty1 ty2) = mkEqPred ty1 ty2 predTreePredType (IPPred ip ty) = mkIPPred ip ty predTreePredType (TuplePred tys) = mkBoxedTupleTy tys predTreePredType (IrredPred ty) = ty @@ -1001,23 +1012,10 @@ typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) varSetElemsKvsFirst :: VarSet -> [TyVar] -- {k1,a,k2,b} --> [k1,k2,a,b] -varSetElemsKvsFirst set = uncurry (++) $ partitionKiTyVars (varSetElems set) - -sortQuantVars :: [Var] -> [Var] --- Sort the variables so the true kind then type variables come first -sortQuantVars = sortLe le +varSetElemsKvsFirst set + = kvs ++ tvs where - v1 `le` v2 = case (is_tv v1, is_tv v2) of - (True, False) -> True - (False, True) -> False - (True, True) -> - case (is_kv v1, is_kv v2) of - (True, False) -> True - (False, True) -> False - _ -> v1 <= v2 -- Same family - (False, False) -> v1 <= v2 - is_tv v = isTyVar v - is_kv v = isSuperKind (tyVarKind v) + (kvs, tvs) = partition isKindVar (varSetElems set) \end{code} @@ -1572,7 +1570,7 @@ type SimpleKind = Kind typeKind :: Type -> Kind typeKind (TyConApp tc tys) | isPromotedTypeTyCon tc - = ASSERT( tyConArity tc == length tys ) tySuperKind + = ASSERT( tyConArity tc == length tys ) superKind | otherwise = kindAppResult (tyConKind tc) tys @@ -1580,14 +1578,14 @@ typeKind (AppTy fun arg) = kindAppResult (typeKind fun) [arg] typeKind (LitTy l) = typeLiteralKind l typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy _arg res) +typeKind _ty@(FunTy _arg res) -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), -- not unliftedTypKind (#) -- The only things that can be after a function arrow are -- (a) types (of kind openTypeKind or its sub-kinds) -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) | isSuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k ) liftedTypeKind + | otherwise = ASSERT2( isSubOpenTypeKind k, ppr _ty $$ ppr k ) liftedTypeKind where k = typeKind res diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 8c60e79bb2..69637b39ed 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -4,6 +4,16 @@ % \section[TypeRep]{Type - friends' interface} +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + TyCon imports Class + TypeRep + TysPrim imports TypeRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type + \begin{code} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. @@ -23,11 +33,11 @@ module TypeRep ( PredType, ThetaType, -- Synonyms -- Functions over types - mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, - isLiftedTypeKind, + mkNakedTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, + isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, -- Pretty-printing - pprType, pprParendType, pprTypeApp, + pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, pprTyThing, pprTyThingCategory, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, @@ -60,6 +70,7 @@ import PrelNames import Outputable import FastString import Pair +import StaticFlags( opt_PprStyle_Debug ) -- libraries import qualified Data.Data as Data hiding ( TyCon ) @@ -255,24 +266,36 @@ mkTyVarTy = TyVarTy mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy --- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. --- Applies its arguments to the constructor from left to right -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys +mkNakedTyConApp :: TyCon -> [Type] -> Type +-- Builds a TyConApp +-- * without being strict in TyCon, +-- * the TyCon should never be a saturated FunTyCon +-- Type.mkTyConApp is the usual one +mkNakedTyConApp tc tys + = TyConApp (ASSERT( not (isFunTyCon tc && length tys == 2) ) tc) tys -- | Create the plain type constructor type which has been applied to no type arguments at all. mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] +mkTyConTy tycon = TyConApp tycon [] +\end{code} +Some basic functions, put here to break loops eg with the pretty printer + +\begin{code} isLiftedTypeKind :: Kind -> Bool --- This function is here because it's used in the pretty printer isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey isLiftedTypeKind _ = False + +-- | Is this a super-kind (i.e. a type-of-kinds)? +isSuperKind :: Type -> Bool +isSuperKind (TyConApp skc []) = skc `hasKey` superKindTyConKey +isSuperKind _ = False + +isTypeVar :: Var -> Bool +isTypeVar v = isTKVar v && not (isSuperKind (varType v)) + +isKindVar :: Var -> Bool +isKindVar v = isTKVar v && isSuperKind (varType v) \end{code} @@ -294,6 +317,7 @@ tyVarsOfType (LitTy {}) = emptyVarSet tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + `unionVarSet` tyVarsOfType (tyVarKind tyvar) tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys @@ -583,7 +607,10 @@ ppr_tylit _ tl = ------------------- pprForAll :: [TyVar] -> SDoc pprForAll [] = empty -pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot +pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot + +pprTvBndrs :: [TyVar] -> SDoc +pprTvBndrs tvs = sep (map pprTvBndr tvs) pprTvBndr :: TyVar -> SDoc pprTvBndr tv @@ -622,47 +649,49 @@ pprTcApp _ _ tc [] -- No brackets for SymOcc | otherwise = empty pprTcApp _ pp tc [ty] - | tc `hasKey` listTyConKey = brackets (pp TopPrec ty) - | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]") - | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") - | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") - | tc `hasKey` openTypeKindTyConKey = ptext (sLit "OpenKind") - | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") - | tc `hasKey` argTypeKindTyConKey = ptext (sLit "ArgKind") - | Just n <- tyConIP_maybe tc = ppr n <> ptext (sLit "::") <> pp TopPrec ty + | tc `hasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty) + | Just n <- tyConIP_maybe tc = ppr n <> ptext (sLit "::") <> pp TopPrec ty pprTcApp p pp tc tys | isTupleTyCon tc && tyConArity tc == length tys - = tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) - | tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because - -- its not a SymOcc so won't get printed infix - , [_, ty1,ty2] <- tys - = pprInfixApp p pp (getName tc) ty1 ty2 + = pprPromotionQuote tc <> + tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) + + | not opt_PprStyle_Debug + , tc `hasKey` eqTyConKey -- We need to special case the type equality TyCon because + , [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix + -- With -dppr-debug switch this off so we can see the kind + = pprInfixApp p pp (ppr tc) ty1 ty2 + | otherwise - = pprTypeNameApp p pp (getName tc) tys + = ppr_type_name_app p pp (ppr tc) (isSymOcc (getOccName tc)) tys ---------------- pprTypeApp :: NamedThing a => a -> [Type] -> SDoc -- The first arg is the tycon, or sometimes class -- Print infix if the tycon/class looks like an operator -pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys +pprTypeApp tc tys + = pprTypeNameApp TopPrec ppr_type (getName tc) tys pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc -- Used for classes and coercions as well as types; that's why it's separate from pprTcApp -pprTypeNameApp p pp tc tys +pprTypeNameApp p pp name tys + = ppr_type_name_app p pp (ppr name) (isSymOcc (getOccName name)) tys + +ppr_type_name_app :: Prec -> (Prec -> a -> SDoc) -> SDoc -> Bool -> [a] -> SDoc +ppr_type_name_app p pp pp_tc is_sym_occ tys | is_sym_occ -- Print infix if possible , [ty1,ty2] <- tys -- We know nothing of precedence though - = pprInfixApp p pp tc ty1 ty2 + = pprInfixApp p pp pp_tc ty1 ty2 | otherwise - = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys) - where - is_sym_occ = isSymOcc (getOccName tc) + = pprPrefixApp p (pprPrefixVar is_sym_occ pp_tc) (map (pp TyConPrec) tys) ---------------- -pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> Name -> a -> a -> SDoc -pprInfixApp p pp tc ty1 ty2 +pprInfixApp :: Prec -> (Prec -> a -> SDoc) -> SDoc -> a -> a -> SDoc +pprInfixApp p pp pp_tc ty1 ty2 = maybeParen p FunPrec $ - sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2] + sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 7d648aef7e..68a61fd860 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -156,9 +156,6 @@ match :: MatchEnv -- For the most part this is pushed downwards -- in-scope set of the RnEnv2 -> Type -> Type -- Template and target respectively -> Maybe TvSubstEnv --- This matcher works on core types; that is, it ignores PredTypes --- Watch out if newtypes become transparent agin! --- this matcher must respect newtypes match menv subst ty1 ty2 | Just ty1' <- coreView ty1 = match menv subst ty1' ty2 | Just ty2' <- coreView ty2 = match menv subst ty1 ty2' diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs index b9ed3e2643..7ba8efbd03 100644 --- a/compiler/utils/GraphColor.hs +++ b/compiler/utils/GraphColor.hs @@ -1,22 +1,13 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} - -{-# 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 - -- | Graph Coloring. --- This is a generic graph coloring library, abstracted over the type of --- the node keys, nodes and colors. +-- This is a generic graph coloring library, abstracted over the type of +-- the node keys, nodes and colors. -- -module GraphColor ( - module GraphBase, - module GraphOps, - module GraphPpr, - colorGraph +module GraphColor ( + module GraphBase, + module GraphOps, + module GraphPpr, + colorGraph ) where @@ -28,325 +19,351 @@ import GraphPpr import Unique import UniqFM import UniqSet -import Outputable +import Outputable import Data.Maybe import Data.List - + -- | Try to color a graph with this set of colors. --- Uses Chaitin's algorithm to color the graph. --- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes --- are pushed onto a stack and removed from the graph. --- Once this process is complete the graph can be colored by removing nodes from --- the stack (ie in reverse order) and assigning them colors different to their neighbors. +-- Uses Chaitin's algorithm to color the graph. +-- The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes +-- are pushed onto a stack and removed from the graph. +-- Once this process is complete the graph can be colored by removing nodes from +-- the stack (ie in reverse order) and assigning them colors different to their neighbors. -- colorGraph - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Eq cls, Ord k - , Outputable k, Outputable cls, Outputable color) - => Bool -- ^ whether to do iterative coalescing - -> Int -- ^ how many times we've tried to color this graph so far. - -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to color. - - -> ( Graph k cls color -- the colored graph. - , UniqSet k -- the set of nodes that we couldn't find a color for. - , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced - -- r1 should be replaced by r2 in the source + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Eq cls, Ord k + , Outputable k, Outputable cls, Outputable color) + => Bool -- ^ whether to do iterative coalescing + -> Int -- ^ how many times we've tried to color this graph so far. + -> UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable. + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to color. + + -> ( Graph k cls color -- the colored graph. + , UniqSet k -- the set of nodes that we couldn't find a color for. + , UniqFM k ) -- map of regs (r1 -> r2) that were coaleced + -- r1 should be replaced by r2 in the source colorGraph iterative spinCount colors triv spill graph0 = let - -- If we're not doing iterative coalescing then do an aggressive coalescing first time - -- around and then conservative coalescing for subsequent passes. - -- - -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if - -- there is a lot of register pressure and we do it on every round then it can make the - -- graph less colorable and prevent the algorithm from converging in a sensible number - -- of cycles. - -- - (graph_coalesced, kksCoalesce1) - = if iterative - then (graph0, []) - else if spinCount == 0 - then coalesceGraph True triv graph0 - else coalesceGraph False triv graph0 - - -- run the scanner to slurp out all the trivially colorable nodes - -- (and do coalescing if iterative coalescing is enabled) - (ksTriv, ksProblems, kksCoalesce2) - = colorScan iterative triv spill graph_coalesced - - -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. - -- We need to apply all the coalescences found by the scanner to the original - -- graph before doing assignColors. - -- - -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing - -- to force all the (conservative) coalescences found during scanning. - -- - (graph_scan_coalesced, _) - = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 - - -- color the trivially colorable nodes - -- during scanning, keys of triv nodes were added to the front of the list as they were found - -- this colors them in the reverse order, as required by the algorithm. - (graph_triv, ksNoTriv) - = assignColors colors graph_scan_coalesced ksTriv - - -- try and color the problem nodes - -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. - (graph_prob, ksNoColor) - = assignColors colors graph_triv ksProblems - - -- if the trivially colorable nodes didn't color then something is probably wrong - -- with the provided triv function. + -- If we're not doing iterative coalescing then do an aggressive coalescing first time + -- around and then conservative coalescing for subsequent passes. + -- + -- Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if + -- there is a lot of register pressure and we do it on every round then it can make the + -- graph less colorable and prevent the algorithm from converging in a sensible number + -- of cycles. -- - in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty - ( empty - $$ text "ksTriv = " <> ppr ksTriv - $$ text "ksNoTriv = " <> ppr ksNoTriv - $$ text "colors = " <> ppr colors - $$ empty - $$ dotGraph (\_ -> text "white") triv graph_triv) - - else ( graph_prob - , mkUniqSet ksNoColor -- the nodes that didn't color (spills) - , if iterative - then (listToUFM kksCoalesce2) - else (listToUFM kksCoalesce1)) - + (graph_coalesced, kksCoalesce1) + = if iterative + then (graph0, []) + else if spinCount == 0 + then coalesceGraph True triv graph0 + else coalesceGraph False triv graph0 + + -- run the scanner to slurp out all the trivially colorable nodes + -- (and do coalescing if iterative coalescing is enabled) + (ksTriv, ksProblems, kksCoalesce2) + = colorScan iterative triv spill graph_coalesced + + -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business. + -- We need to apply all the coalescences found by the scanner to the original + -- graph before doing assignColors. + -- + -- Because we've got the whole, non-pruned graph here we turn on aggressive coalecing + -- to force all the (conservative) coalescences found during scanning. + -- + (graph_scan_coalesced, _) + = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2 + + -- color the trivially colorable nodes + -- during scanning, keys of triv nodes were added to the front of the list as they were found + -- this colors them in the reverse order, as required by the algorithm. + (graph_triv, ksNoTriv) + = assignColors colors graph_scan_coalesced ksTriv + + -- try and color the problem nodes + -- problem nodes are the ones that were left uncolored because they weren't triv. + -- theres a change we can color them here anyway. + (graph_prob, ksNoColor) + = assignColors colors graph_triv ksProblems + + -- if the trivially colorable nodes didn't color then something is probably wrong + -- with the provided triv function. + -- + in if not $ null ksNoTriv + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty + $$ text "ksTriv = " <> ppr ksTriv + $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors + $$ empty + $$ dotGraph (\_ -> text "white") triv graph_triv) + + else ( graph_prob + , mkUniqSet ksNoColor -- the nodes that didn't color (spills) + , if iterative + then (listToUFM kksCoalesce2) + else (listToUFM kksCoalesce1)) + -- | Scan through the conflict graph separating out trivially colorable and --- potentially uncolorable (problem) nodes. +-- potentially uncolorable (problem) nodes. -- --- Checking whether a node is trivially colorable or not is a resonably expensive operation, --- so after a triv node is found and removed from the graph it's no good to return to the 'start' --- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. +-- Checking whether a node is trivially colorable or not is a resonably expensive operation, +-- so after a triv node is found and removed from the graph it's no good to return to the 'start' +-- of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable. -- --- To ward against this, during each pass through the graph we collect up a list of triv nodes --- that were found, and only remove them once we've finished the pass. The more nodes we can delete --- at once the more likely it is that nodes we've already checked will become trivially colorable --- for the next pass. +-- To ward against this, during each pass through the graph we collect up a list of triv nodes +-- that were found, and only remove them once we've finished the pass. The more nodes we can delete +-- at once the more likely it is that nodes we've already checked will become trivially colorable +-- for the next pass. -- --- TODO: add work lists to finding triv nodes is easier. --- If we've just scanned the graph, and removed triv nodes, then the only --- nodes that we need to rescan are the ones we've removed edges from. +-- TODO: add work lists to finding triv nodes is easier. +-- If we've just scanned the graph, and removed triv nodes, then the only +-- nodes that we need to rescan are the ones we've removed edges from. colorScan - :: ( Uniquable k, Uniquable cls, Uniquable color - , Ord k, Eq cls - , Outputable k, Outputable cls) - => Bool -- ^ whether to do iterative coalescing - -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable - -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. - -> Graph k cls color -- ^ the graph to scan + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool -- ^ whether to do iterative coalescing + -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable + -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. + -> Graph k cls color -- ^ the graph to scan - -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce + -> ([k], [k], [(k, k)]) -- triv colorable nodes, problem nodes, pairs of nodes to coalesce colorScan iterative triv spill graph - = colorScan_spin iterative triv spill graph [] [] [] + = colorScan_spin iterative triv spill graph [] [] [] + +colorScan_spin + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) colorScan_spin iterative triv spill graph - ksTriv ksSpill kksCoalesce - - -- if the graph is empty then we're done - | isNullUFM $ graphMap graph - = (ksTriv, ksSpill, reverse kksCoalesce) - - -- Simplify: - -- Look for trivially colorable nodes. - -- If we can find some then remove them from the graph and go back for more. - -- - | nsTrivFound@(_:_) - <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - - -- for iterative coalescing we only want non-move related - -- nodes here - && (not iterative || isEmptyUniqSet (nodeCoalesce node))) - $ graph - - , ksTrivFound <- map nodeId nsTrivFound - , graph2 <- foldr (\k g -> let Just g' = delNode k g - in g') - graph ksTrivFound - - = colorScan_spin iterative triv spill graph2 - (ksTrivFound ++ ksTriv) - ksSpill - kksCoalesce - - -- Coalesce: - -- If we're doing iterative coalescing and no triv nodes are avaliable - -- then it's time for a coalescing pass. - | iterative - = case coalesceGraph False triv graph of - - -- we were able to coalesce something - -- go back to Simplify and see if this frees up more nodes to be trivially colorable. - (graph2, kksCoalesceFound @(_:_)) - -> colorScan_spin iterative triv spill graph2 - ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) - - -- Freeze: - -- nothing could be coalesced (or was triv), - -- time to choose a node to freeze and give up on ever coalescing it. - (graph2, []) - -> case freezeOneInGraph graph2 of - - -- we were able to freeze something - -- hopefully this will free up something for Simplify - (graph3, True) - -> colorScan_spin iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- we couldn't find something to freeze either - -- time for a spill - (graph3, False) - -> colorScan_spill iterative triv spill graph3 - ksTriv ksSpill kksCoalesce - - -- spill time - | otherwise - = colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce + ksTriv ksSpill kksCoalesce + + -- if the graph is empty then we're done + | isNullUFM $ graphMap graph + = (ksTriv, ksSpill, reverse kksCoalesce) + + -- Simplify: + -- Look for trivially colorable nodes. + -- If we can find some then remove them from the graph and go back for more. + -- + | nsTrivFound@(_:_) + <- scanGraph (\node -> triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + + -- for iterative coalescing we only want non-move related + -- nodes here + && (not iterative || isEmptyUniqSet (nodeCoalesce node))) + $ graph + + , ksTrivFound <- map nodeId nsTrivFound + , graph2 <- foldr (\k g -> let Just g' = delNode k g + in g') + graph ksTrivFound + + = colorScan_spin iterative triv spill graph2 + (ksTrivFound ++ ksTriv) + ksSpill + kksCoalesce + + -- Coalesce: + -- If we're doing iterative coalescing and no triv nodes are avaliable + -- then it's time for a coalescing pass. + | iterative + = case coalesceGraph False triv graph of + + -- we were able to coalesce something + -- go back to Simplify and see if this frees up more nodes to be trivially colorable. + (graph2, kksCoalesceFound @(_:_)) + -> colorScan_spin iterative triv spill graph2 + ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce) + + -- Freeze: + -- nothing could be coalesced (or was triv), + -- time to choose a node to freeze and give up on ever coalescing it. + (graph2, []) + -> case freezeOneInGraph graph2 of + + -- we were able to freeze something + -- hopefully this will free up something for Simplify + (graph3, True) + -> colorScan_spin iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- we couldn't find something to freeze either + -- time for a spill + (graph3, False) + -> colorScan_spill iterative triv spill graph3 + ksTriv ksSpill kksCoalesce + + -- spill time + | otherwise + = colorScan_spill iterative triv spill graph + ksTriv ksSpill kksCoalesce -- Select: -- we couldn't find any triv nodes or things to freeze or coalesce, --- and the graph isn't empty yet.. We'll have to choose a spill --- candidate and leave it uncolored. +-- and the graph isn't empty yet.. We'll have to choose a spill +-- candidate and leave it uncolored. -- +colorScan_spill + :: ( Uniquable k, Uniquable cls, Uniquable color + , Ord k, Eq cls + , Outputable k, Outputable cls) + => Bool + -> Triv k cls color + -> (Graph k cls color -> k) + -> Graph k cls color + -> [k] + -> [k] + -> [(k, k)] + -> ([k], [k], [(k, k)]) + colorScan_spill iterative triv spill graph - ksTriv ksSpill kksCoalesce + ksTriv ksSpill kksCoalesce + + = let kSpill = spill graph + Just graph' = delNode kSpill graph + in colorScan_spin iterative triv spill graph' + ksTriv (kSpill : ksSpill) kksCoalesce - = let kSpill = spill graph - Just graph' = delNode kSpill graph - in colorScan_spin iterative triv spill graph' - ksTriv (kSpill : ksSpill) kksCoalesce - -- | Try to assign a color to all these nodes. -assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> [k] -- ^ nodes to assign a color to. - -> ( Graph k cls color -- the colored graph - , [k]) -- the nodes that didn't color. +assignColors + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> [k] -- ^ nodes to assign a color to. + -> ( Graph k cls color -- the colored graph + , [k]) -- the nodes that didn't color. + +assignColors colors graph ks + = assignColors' colors graph [] ks + + where assignColors' _ graph prob [] + = (graph, prob) -assignColors colors graph ks - = assignColors' colors graph [] ks + assignColors' colors graph prob (k:ks) + = case assignColor colors k graph of - where assignColors' _ graph prob [] - = (graph, prob) + -- couldn't color this node + Nothing -> assignColors' colors graph (k : prob) ks - assignColors' colors graph prob (k:ks) - = case assignColor colors k graph of + -- this node colored ok, so do the rest + Just graph' -> assignColors' colors graph' prob ks - -- couldn't color this node - Nothing -> assignColors' colors graph (k : prob) ks - -- this node colored ok, so do the rest - Just graph' -> assignColors' colors graph' prob ks + assignColor colors u graph + | Just c <- selectColor colors graph u + = Just (setColor u c graph) + | otherwise + = Nothing - assignColor colors u graph - | Just c <- selectColor colors graph u - = Just (setColor u c graph) - | otherwise - = Nothing - - -- | Select a color for a certain node --- taking into account preferences, neighbors and exclusions. --- returns Nothing if no color can be assigned to this node. +-- taking into account preferences, neighbors and exclusions. +-- returns Nothing if no color can be assigned to this node. -- selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color - , Eq color, Outputable cls) - => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). - -> Graph k cls color -- ^ the graph - -> k -- ^ key of the node to select a color for. - -> Maybe color - -selectColor colors graph u - = let -- lookup the node - Just node = lookupNode graph u - - -- lookup the available colors for the class of this node. - colors_avail - = case lookupUFM colors (nodeClass node) of - Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) - Just cs -> cs - - -- find colors we can't use because they're already being used - -- by a node that conflicts with this one. - Just nsConflicts - = sequence - $ map (lookupNode graph) - $ uniqSetToList - $ nodeConflicts node - - colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts - - -- the prefs of our neighbors - colors_neighbor_prefs - = mkUniqSet - $ concat $ map nodePreference nsConflicts - - -- colors that are still valid for us - colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) - colors_ok = minusUniqSet colors_ok_ex colors_conflict - - -- the colors that we prefer, and are still ok - colors_ok_pref = intersectUniqSets - (mkUniqSet $ nodePreference node) colors_ok - - -- the colors that we could choose while being nice to our neighbors - colors_ok_nice = minusUniqSet - colors_ok colors_neighbor_prefs - - -- the best of all possible worlds.. - colors_ok_pref_nice - = intersectUniqSets - colors_ok_nice colors_ok_pref - - -- make the decision - chooseColor - - -- everyone is happy, yay! - | not $ isEmptyUniqSet colors_ok_pref_nice - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) - (nodePreference node) - = Just c - - -- we've got one of our preferences - | not $ isEmptyUniqSet colors_ok_pref - , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) - (nodePreference node) - = Just c - - -- it wasn't a preference, but it was still ok - | not $ isEmptyUniqSet colors_ok - , c : _ <- uniqSetToList colors_ok - = Just c - - -- no colors were available for us this time. - -- looks like we're going around the loop again.. - | otherwise - = Nothing - - in chooseColor + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) + => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). + -> Graph k cls color -- ^ the graph + -> k -- ^ key of the node to select a color for. + -> Maybe color + +selectColor colors graph u + = let -- lookup the node + Just node = lookupNode graph u + + -- lookup the available colors for the class of this node. + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs + + -- find colors we can't use because they're already being used + -- by a node that conflicts with this one. + Just nsConflicts + = sequence + $ map (lookupNode graph) + $ uniqSetToList + $ nodeConflicts node + + colors_conflict = mkUniqSet + $ catMaybes + $ map nodeColor nsConflicts + + -- the prefs of our neighbors + colors_neighbor_prefs + = mkUniqSet + $ concat $ map nodePreference nsConflicts + + -- colors that are still valid for us + colors_ok_ex = minusUniqSet colors_avail (nodeExclusions node) + colors_ok = minusUniqSet colors_ok_ex colors_conflict + + -- the colors that we prefer, and are still ok + colors_ok_pref = intersectUniqSets + (mkUniqSet $ nodePreference node) colors_ok + + -- the colors that we could choose while being nice to our neighbors + colors_ok_nice = minusUniqSet + colors_ok colors_neighbor_prefs + + -- the best of all possible worlds.. + colors_ok_pref_nice + = intersectUniqSets + colors_ok_nice colors_ok_pref + + -- make the decision + chooseColor + + -- everyone is happy, yay! + | not $ isEmptyUniqSet colors_ok_pref_nice + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice) + (nodePreference node) + = Just c + + -- we've got one of our preferences + | not $ isEmptyUniqSet colors_ok_pref + , c : _ <- filter (\x -> elementOfUniqSet x colors_ok_pref) + (nodePreference node) + = Just c + + -- it wasn't a preference, but it was still ok + | not $ isEmptyUniqSet colors_ok + , c : _ <- uniqSetToList colors_ok + = Just c + + -- no colors were available for us this time. + -- looks like we're going around the loop again.. + | otherwise + = Nothing + + in chooseColor diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 69d4943fb0..7bf3ecdffb 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -1,28 +1,20 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -{-# 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 - -- | Basic operations on graphs. -- module GraphOps ( - addNode, delNode, getNode, lookupNode, modNode, - size, - union, - addConflict, delConflict, addConflicts, - addCoalesce, delCoalesce, - addExclusion, addExclusions, - addPreference, - coalesceNodes, coalesceGraph, - freezeNode, freezeOneInGraph, freezeAllInGraph, - scanGraph, - setColor, - validateGraph, - slurpNodeConflictCount + addNode, delNode, getNode, lookupNode, modNode, + size, + union, + addConflict, delConflict, addConflicts, + addCoalesce, delCoalesce, + addExclusion, addExclusions, + addPreference, + coalesceNodes, coalesceGraph, + freezeNode, freezeOneInGraph, freezeAllInGraph, + scanGraph, + setColor, + validateGraph, + slurpNodeConflictCount ) where @@ -33,610 +25,641 @@ import Unique import UniqSet import UniqFM -import Data.List hiding (union) +import Data.List hiding (union) import Data.Maybe -- | Lookup a node from the graph. -lookupNode - :: Uniquable k - => Graph k cls color - -> k -> Maybe (Node k cls color) +lookupNode + :: Uniquable k + => Graph k cls color + -> k -> Maybe (Node k cls color) -lookupNode graph k - = lookupUFM (graphMap graph) k +lookupNode graph k + = lookupUFM (graphMap graph) k -- | Get a node from the graph, throwing an error if it's not there getNode - :: Uniquable k - => Graph k cls color - -> k -> Node k cls color + :: Uniquable k + => Graph k cls color + -> k -> Node k cls color getNode graph k = case lookupUFM (graphMap graph) k of - Just node -> node - Nothing -> panic "ColorOps.getNode: not found" + Just node -> node + Nothing -> panic "ColorOps.getNode: not found" -- | Add a node to the graph, linking up its edges addNode :: Uniquable k - => k -> Node k cls color - -> Graph k cls color -> Graph k cls color - + => k -> Node k cls color + -> Graph k cls color -> Graph k cls color + addNode k node graph - = let - -- add back conflict edges from other nodes to this one - map_conflict - = foldUniqSet - (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) - (graphMap graph) - (nodeConflicts node) - - -- add back coalesce edges from other nodes to this one - map_coalesce - = foldUniqSet - (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) - map_conflict - (nodeCoalesce node) - - in graph - { graphMap = addToUFM map_coalesce k node} - + = let + -- add back conflict edges from other nodes to this one + map_conflict + = foldUniqSet + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (graphMap graph) + (nodeConflicts node) + + -- add back coalesce edges from other nodes to this one + map_coalesce + = foldUniqSet + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + map_conflict + (nodeCoalesce node) + + in graph + { graphMap = addToUFM map_coalesce k node} + -- | Delete a node and all its edges from the graph. delNode :: (Uniquable k, Outputable k) - => k -> Graph k cls color -> Maybe (Graph k cls color) + => k -> Graph k cls color -> Maybe (Graph k cls color) delNode k graph - | Just node <- lookupNode graph k - = let -- delete conflict edges from other nodes to this one. - graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph - $ uniqSetToList (nodeConflicts node) - - -- delete coalesce edge from other nodes to this one. - graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 - $ uniqSetToList (nodeCoalesce node) - - -- delete the node - graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 - - in Just graph3 - - | otherwise - = Nothing + | Just node <- lookupNode graph k + = let -- delete conflict edges from other nodes to this one. + graph1 = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph + $ uniqSetToList (nodeConflicts node) + + -- delete coalesce edge from other nodes to this one. + graph2 = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1 + $ uniqSetToList (nodeCoalesce node) + + -- delete the node + graph3 = graphMapModify (\fm -> delFromUFM fm k) graph2 + + in Just graph3 + + | otherwise + = Nothing -- | Modify a node in the graph. --- returns Nothing if the node isn't present. +-- returns Nothing if the node isn't present. -- modNode :: Uniquable k - => (Node k cls color -> Node k cls color) - -> k -> Graph k cls color -> Maybe (Graph k cls color) + => (Node k cls color -> Node k cls color) + -> k -> Graph k cls color -> Maybe (Graph k cls color) modNode f k graph = case lookupNode graph k of - Just Node{} - -> Just - $ graphMapModify - (\fm -> let Just node = lookupUFM fm k - node' = f node - in addToUFM fm k node') - graph + Just Node{} + -> Just + $ graphMapModify + (\fm -> let Just node = lookupUFM fm k + node' = f node + in addToUFM fm k node') + graph - Nothing -> Nothing + Nothing -> Nothing -- | Get the size of the graph, O(n) -size :: Uniquable k - => Graph k cls color -> Int - -size graph - = sizeUFM $ graphMap graph - +size :: Uniquable k + => Graph k cls color -> Int + +size graph + = sizeUFM $ graphMap graph + -- | Union two graphs together. -union :: Uniquable k - => Graph k cls color -> Graph k cls color -> Graph k cls color - -union graph1 graph2 - = Graph - { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } +union :: Uniquable k + => Graph k cls color -> Graph k cls color -> Graph k cls color + +union graph1 graph2 + = Graph + { graphMap = plusUFM (graphMap graph1) (graphMap graph2) } -- | Add a conflict between nodes to the graph, creating the nodes required. --- Conflicts are virtual regs which need to be colored differently. +-- Conflicts are virtual regs which need to be colored differently. addConflict - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color addConflict (u1, c1) (u2, c2) - = let addNeighbor u c u' - = adjustWithDefaultUFM - (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) - (newNode u c) { nodeConflicts = unitUniqSet u' } - u - - in graphMapModify - ( addNeighbor u1 c1 u2 - . addNeighbor u2 c2 u1) - - + = let addNeighbor u c u' + = adjustWithDefaultUFM + (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' }) + (newNode u c) { nodeConflicts = unitUniqSet u' } + u + + in graphMapModify + ( addNeighbor u1 c1 u2 + . addNeighbor u2 c2 u1) + + -- | Delete a conflict edge. k1 -> k2 --- returns Nothing if the node isn't in the graph -delConflict - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) - +-- returns Nothing if the node isn't in the graph +delConflict + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) + delConflict k1 k2 - = modNode - (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) - k1 + = modNode + (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 }) + k1 -- | Add some conflicts to the graph, creating nodes if required. --- All the nodes in the set are taken to conflict with each other. +-- All the nodes in the set are taken to conflict with each other. addConflicts - :: Uniquable k - => UniqSet k -> (k -> cls) - -> Graph k cls color -> Graph k cls color - -addConflicts conflicts getClass - - -- just a single node, but no conflicts, create the node anyway. - | (u : []) <- uniqSetToList conflicts - = graphMapModify - $ adjustWithDefaultUFM - id - (newNode u (getClass u)) - u - - | otherwise - = graphMapModify - $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm - $ uniqSetToList conflicts) + :: Uniquable k + => UniqSet k -> (k -> cls) + -> Graph k cls color -> Graph k cls color +addConflicts conflicts getClass -addConflictSet1 u getClass set + -- just a single node, but no conflicts, create the node anyway. + | (u : []) <- uniqSetToList conflicts + = graphMapModify + $ adjustWithDefaultUFM + id + (newNode u (getClass u)) + u + + | otherwise + = graphMapModify + $ (\fm -> foldl' (\g u -> addConflictSet1 u getClass conflicts g) fm + $ uniqSetToList conflicts) + + +addConflictSet1 :: Uniquable k + => k -> (k -> cls) -> UniqSet k + -> UniqFM (Node k cls color) + -> UniqFM (Node k cls color) +addConflictSet1 u getClass set = case delOneFromUniqSet set u of set' -> adjustWithDefaultUFM - (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) - (newNode u (getClass u)) { nodeConflicts = set' } - u + (\node -> node { nodeConflicts = unionUniqSets set' (nodeConflicts node) } ) + (newNode u (getClass u)) { nodeConflicts = set' } + u -- | Add an exclusion to the graph, creating nodes if required. --- These are extra colors that the node cannot use. +-- These are extra colors that the node cannot use. addExclusion - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> color - -> Graph k cls color -> Graph k cls color - -addExclusion u getClass color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) - (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } - u + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> color + -> Graph k cls color -> Graph k cls color + +addExclusion u getClass color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodeExclusions = addOneToUniqSet (nodeExclusions node) color }) + (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } + u addExclusions - :: (Uniquable k, Uniquable color) - => k -> (k -> cls) -> [color] - -> Graph k cls color -> Graph k cls color + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color addExclusions u getClass colors graph - = foldr (addExclusion u getClass) graph colors + = foldr (addExclusion u getClass) graph colors -- | Add a coalescence edge to the graph, creating nodes if requried. --- It is considered adventageous to assign the same color to nodes in a coalesence. -addCoalesce - :: Uniquable k - => (k, cls) -> (k, cls) - -> Graph k cls color -> Graph k cls color - -addCoalesce (u1, c1) (u2, c2) - = let addCoalesce u c u' - = adjustWithDefaultUFM - (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) - (newNode u c) { nodeCoalesce = unitUniqSet u' } - u - - in graphMapModify - ( addCoalesce u1 c1 u2 +-- It is considered adventageous to assign the same color to nodes in a coalesence. +addCoalesce + :: Uniquable k + => (k, cls) -> (k, cls) + -> Graph k cls color -> Graph k cls color + +addCoalesce (u1, c1) (u2, c2) + = let addCoalesce u c u' + = adjustWithDefaultUFM + (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' }) + (newNode u c) { nodeCoalesce = unitUniqSet u' } + u + + in graphMapModify + ( addCoalesce u1 c1 u2 . addCoalesce u2 c2 u1) -- | Delete a coalescence edge (k1 -> k2) from the graph. delCoalesce - :: Uniquable k - => k -> k - -> Graph k cls color -> Maybe (Graph k cls color) + :: Uniquable k + => k -> k + -> Graph k cls color -> Maybe (Graph k cls color) delCoalesce k1 k2 - = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) - k1 + = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 }) + k1 -- | Add a color preference to the graph, creating nodes if required. --- The most recently added preference is the most prefered. --- The algorithm tries to assign a node it's prefered color if possible. +-- The most recently added preference is the most prefered. +-- The algorithm tries to assign a node it's prefered color if possible. -- -addPreference - :: Uniquable k - => (k, cls) -> color - -> Graph k cls color -> Graph k cls color - -addPreference (u, c) color - = graphMapModify - $ adjustWithDefaultUFM - (\node -> node { nodePreference = color : (nodePreference node) }) - (newNode u c) { nodePreference = [color] } - u +addPreference + :: Uniquable k + => (k, cls) -> color + -> Graph k cls color -> Graph k cls color + +addPreference (u, c) color + = graphMapModify + $ adjustWithDefaultUFM + (\node -> node { nodePreference = color : (nodePreference node) }) + (newNode u c) { nodePreference = [color] } + u -- | Do agressive coalescing on this graph. --- returns the new graph and the list of pairs of nodes that got coaleced together. --- for each pair, the resulting node will have the least key and be second in the pair. +-- returns the new graph and the list of pairs of nodes that got coaleced together. +-- for each pair, the resulting node will have the least key and be second in the pair. -- coalesceGraph - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> ( Graph k cls color - , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the - -- coalescing was applied. + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> ( Graph k cls color + , [(k, k)]) -- pairs of nodes that were coalesced, in the order that the + -- coalescing was applied. coalesceGraph aggressive triv graph - = coalesceGraph' aggressive triv graph [] - + = coalesceGraph' aggressive triv graph [] + +coalesceGraph' + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> [(k, k)] + -> ( Graph k cls color + , [(k, k)]) coalesceGraph' aggressive triv graph kkPairsAcc = let - -- find all the nodes that have coalescence edges - cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) - $ eltsUFM $ graphMap graph - - -- build a list of pairs of keys for node's we'll try and coalesce - -- every pair of nodes will appear twice in this list - -- ie [(k1, k2), (k2, k1) ... ] - -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for - -- build a list of what nodes get coalesced together for later on. - -- - cList = [ (nodeId node1, k2) - | node1 <- cNodes - , k2 <- uniqSetToList $ nodeCoalesce node1 ] - - -- do the coalescing, returning the new graph and a list of pairs of keys - -- that got coalesced together. - (graph', mPairs) - = mapAccumL (coalesceNodes aggressive triv) graph cList - - -- keep running until there are no more coalesces can be found - in case catMaybes mPairs of - [] -> (graph', reverse kkPairsAcc) - pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) + -- find all the nodes that have coalescence edges + cNodes = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) + $ eltsUFM $ graphMap graph + + -- build a list of pairs of keys for node's we'll try and coalesce + -- every pair of nodes will appear twice in this list + -- ie [(k1, k2), (k2, k1) ... ] + -- This is ok, GrapOps.coalesceNodes handles this and it's convenient for + -- build a list of what nodes get coalesced together for later on. + -- + cList = [ (nodeId node1, k2) + | node1 <- cNodes + , k2 <- uniqSetToList $ nodeCoalesce node1 ] + + -- do the coalescing, returning the new graph and a list of pairs of keys + -- that got coalesced together. + (graph', mPairs) + = mapAccumL (coalesceNodes aggressive triv) graph cList + + -- keep running until there are no more coalesces can be found + in case catMaybes mPairs of + [] -> (graph', reverse kkPairsAcc) + pairs -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc) -- | Coalesce this pair of nodes unconditionally \/ agressively. --- The resulting node is the one with the least key. +-- The resulting node is the one with the least key. -- --- returns: Just the pair of keys if the nodes were coalesced --- the second element of the pair being the least one +-- returns: Just the pair of keys if the nodes were coalesced +-- the second element of the pair being the least one -- --- Nothing if either of the nodes weren't in the graph +-- Nothing if either of the nodes weren't in the graph coalesceNodes - :: (Uniquable k, Ord k, Eq cls, Outputable k) - => Bool -- ^ If True, coalesce nodes even if this might make the graph - -- less colorable (aggressive coalescing) - -> Triv k cls color - -> Graph k cls color - -> (k, k) -- ^ keys of the nodes to be coalesced - -> (Graph k cls color, Maybe (k, k)) + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool -- ^ If True, coalesce nodes even if this might make the graph + -- less colorable (aggressive coalescing) + -> Triv k cls color + -> Graph k cls color + -> (k, k) -- ^ keys of the nodes to be coalesced + -> (Graph k cls color, Maybe (k, k)) coalesceNodes aggressive triv graph (k1, k2) - | (kMin, kMax) <- if k1 < k2 - then (k1, k2) - else (k2, k1) - - -- the nodes being coalesced must be in the graph - , Just nMin <- lookupNode graph kMin - , Just nMax <- lookupNode graph kMax - - -- can't coalesce conflicting modes - , not $ elementOfUniqSet kMin (nodeConflicts nMax) - , not $ elementOfUniqSet kMax (nodeConflicts nMin) - - -- can't coalesce the same node - , nodeId nMin /= nodeId nMax - - = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax + | (kMin, kMax) <- if k1 < k2 + then (k1, k2) + else (k2, k1) - -- don't do the coalescing after all - | otherwise - = (graph, Nothing) + -- the nodes being coalesced must be in the graph + , Just nMin <- lookupNode graph kMin + , Just nMax <- lookupNode graph kMax -coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - - -- sanity checks - | nodeClass nMin /= nodeClass nMax - = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + -- can't coalesce conflicting modes + , not $ elementOfUniqSet kMin (nodeConflicts nMax) + , not $ elementOfUniqSet kMax (nodeConflicts nMin) - | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) - = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + -- can't coalesce the same node + , nodeId nMin /= nodeId nMax - --- - | otherwise - = let - -- the new node gets all the edges from its two components - node = - Node { nodeId = kMin - , nodeClass = nodeClass nMin - , nodeColor = Nothing + = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - -- nodes don't conflict with themselves.. - , nodeConflicts - = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax + -- don't do the coalescing after all + | otherwise + = (graph, Nothing) - , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) - , nodePreference = nodePreference nMin ++ nodePreference nMax +coalesceNodes_merge + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) - -- nodes don't coalesce with themselves.. - , nodeCoalesce - = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) - `delOneFromUniqSet` kMin - `delOneFromUniqSet` kMax - } +coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax - in coalesceNodes_check aggressive triv graph kMin kMax node + -- sanity checks + | nodeClass nMin /= nodeClass nMax + = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes." + + | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax)) + = error "GraphOps.coalesceNodes: can't coalesce colored nodes." + + --- + | otherwise + = let + -- the new node gets all the edges from its two components + node = + Node { nodeId = kMin + , nodeClass = nodeClass nMin + , nodeColor = Nothing + + -- nodes don't conflict with themselves.. + , nodeConflicts + = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + + , nodeExclusions = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax) + , nodePreference = nodePreference nMin ++ nodePreference nMax + + -- nodes don't coalesce with themselves.. + , nodeCoalesce + = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax)) + `delOneFromUniqSet` kMin + `delOneFromUniqSet` kMax + } + + in coalesceNodes_check aggressive triv graph kMin kMax node + +coalesceNodes_check + :: (Uniquable k, Ord k, Eq cls, Outputable k) + => Bool + -> Triv k cls color + -> Graph k cls color + -> k -> k + -> Node k cls color + -> (Graph k cls color, Maybe (k, k)) coalesceNodes_check aggressive triv graph kMin kMax node - -- Unless we're coalescing aggressively, if the result node is not trivially - -- colorable then don't do the coalescing. - | not aggressive - , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) - = (graph, Nothing) + -- Unless we're coalescing aggressively, if the result node is not trivially + -- colorable then don't do the coalescing. + | not aggressive + , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node) + = (graph, Nothing) - | otherwise - = let -- delete the old nodes from the graph and add the new one - Just graph1 = delNode kMax graph - Just graph2 = delNode kMin graph1 - graph3 = addNode kMin node graph2 + | otherwise + = let -- delete the old nodes from the graph and add the new one + Just graph1 = delNode kMax graph + Just graph2 = delNode kMin graph1 + graph3 = addNode kMin node graph2 - in (graph3, Just (kMax, kMin)) + in (graph3, Just (kMax, kMin)) -- | Freeze a node --- This is for the iterative coalescer. --- By freezing a node we give up on ever coalescing it. --- Move all its coalesce edges into the frozen set - and update --- back edges from other nodes. +-- This is for the iterative coalescer. +-- By freezing a node we give up on ever coalescing it. +-- Move all its coalesce edges into the frozen set - and update +-- back edges from other nodes. -- freezeNode - :: Uniquable k - => k -- ^ key of the node to freeze - -> Graph k cls color -- ^ the graph - -> Graph k cls color -- ^ graph with that node frozen + :: Uniquable k + => k -- ^ key of the node to freeze + -> Graph k cls color -- ^ the graph + -> Graph k cls color -- ^ graph with that node frozen freezeNode k = graphMapModify $ \fm -> - let -- freeze all the edges in the node to be frozen - Just node = lookupUFM fm k - node' = node - { nodeCoalesce = emptyUniqSet } + let -- freeze all the edges in the node to be frozen + Just node = lookupUFM fm k + node' = node + { nodeCoalesce = emptyUniqSet } - fm1 = addToUFM fm k node' + fm1 = addToUFM fm k node' - -- update back edges pointing to this node - freezeEdge k node - = if elementOfUniqSet k (nodeCoalesce node) - then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } - else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. + -- update back edges pointing to this node + freezeEdge k node + = if elementOfUniqSet k (nodeCoalesce node) + then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } + else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" + -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 - $ nodeCoalesce node + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 + $ nodeCoalesce node - in fm2 + in fm2 -- | Freeze one node in the graph --- This if for the iterative coalescer. --- Look for a move related node of low degree and freeze it. +-- This if for the iterative coalescer. +-- Look for a move related node of low degree and freeze it. -- --- We probably don't need to scan the whole graph looking for the node of absolute --- lowest degree. Just sample the first few and choose the one with the lowest --- degree out of those. Also, we don't make any distinction between conflicts of different --- classes.. this is just a heuristic, after all. +-- We probably don't need to scan the whole graph looking for the node of absolute +-- lowest degree. Just sample the first few and choose the one with the lowest +-- degree out of those. Also, we don't make any distinction between conflicts of different +-- classes.. this is just a heuristic, after all. -- --- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv --- right here, and add it to a worklist if known triv\/non-move nodes. +-- IDEA: freezing a node might free it up for Simplify.. would be good to check for triv +-- right here, and add it to a worklist if known triv\/non-move nodes. -- freezeOneInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> ( Graph k cls color -- the new graph - , Bool ) -- whether we found a node to freeze + :: (Uniquable k, Outputable k) + => Graph k cls color + -> ( Graph k cls color -- the new graph + , Bool ) -- whether we found a node to freeze freezeOneInGraph graph - = let compareNodeDegree n1 n2 - = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) + = let compareNodeDegree n1 n2 + = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2) - candidates - = sortBy compareNodeDegree - $ take 5 -- 5 isn't special, it's just a small number. - $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph + candidates + = sortBy compareNodeDegree + $ take 5 -- 5 isn't special, it's just a small number. + $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph - in case candidates of + in case candidates of - -- there wasn't anything available to freeze - [] -> (graph, False) + -- there wasn't anything available to freeze + [] -> (graph, False) - -- we found something to freeze - (n : _) - -> ( freezeNode (nodeId n) graph - , True) + -- we found something to freeze + (n : _) + -> ( freezeNode (nodeId n) graph + , True) -- | Freeze all the nodes in the graph --- for debugging the iterative allocator. +-- for debugging the iterative allocator. -- freezeAllInGraph - :: (Uniquable k, Outputable k) - => Graph k cls color - -> Graph k cls color + :: (Uniquable k, Outputable k) + => Graph k cls color + -> Graph k cls color freezeAllInGraph graph - = foldr freezeNode graph - $ map nodeId - $ eltsUFM $ graphMap graph + = foldr freezeNode graph + $ map nodeId + $ eltsUFM $ graphMap graph -- | Find all the nodes in the graph that meet some criteria -- scanGraph - :: Uniquable k - => (Node k cls color -> Bool) - -> Graph k cls color - -> [Node k cls color] + :: Uniquable k + => (Node k cls color -> Bool) + -> Graph k cls color + -> [Node k cls color] scanGraph match graph - = filter match $ eltsUFM $ graphMap graph + = filter match $ eltsUFM $ graphMap graph -- | validate the internal structure of a graph --- all its edges should point to valid nodes --- If they don't then throw an error +-- all its edges should point to valid nodes +-- If they don't then throw an error -- validateGraph - :: (Uniquable k, Outputable k, Eq color) - => SDoc -- ^ extra debugging info to display on error - -> Bool -- ^ whether this graph is supposed to be colored. - -> Graph k cls color -- ^ graph to validate - -> Graph k cls color -- ^ validated graph + :: (Uniquable k, Outputable k, Eq color) + => SDoc -- ^ extra debugging info to display on error + -> Bool -- ^ whether this graph is supposed to be colored. + -> Graph k cls color -- ^ graph to validate + -> Graph k cls color -- ^ validated graph validateGraph doc isColored graph - -- Check that all edges point to valid nodes. - | edges <- unionManyUniqSets - ( (map nodeConflicts $ eltsUFM $ graphMap graph) - ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) - - , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph - , badEdges <- minusUniqSet edges nodes - , not $ isEmptyUniqSet badEdges - = pprPanic "GraphOps.validateGraph" - ( text "Graph has edges that point to non-existant nodes" - $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) - $$ doc ) - - -- Check that no conflicting nodes have the same color - | badNodes <- filter (not . (checkNode graph)) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Node has same color as one of it's conflicts" - $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc) - - -- If this is supposed to be a colored graph, - -- check that all nodes have a color. - | isColored - , badNodes <- filter (\n -> isNothing $ nodeColor n) - $ eltsUFM $ graphMap graph - , not $ null badNodes - = pprPanic "GraphOps.validateGraph" - ( text "Supposably colored graph has uncolored nodes." - $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) - $$ doc ) - - - -- graph looks ok - | otherwise - = graph + -- Check that all edges point to valid nodes. + | edges <- unionManyUniqSets + ( (map nodeConflicts $ eltsUFM $ graphMap graph) + ++ (map nodeCoalesce $ eltsUFM $ graphMap graph)) + + , nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph + , badEdges <- minusUniqSet edges nodes + , not $ isEmptyUniqSet badEdges + = pprPanic "GraphOps.validateGraph" + ( text "Graph has edges that point to non-existant nodes" + $$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges) + $$ doc ) + + -- Check that no conflicting nodes have the same color + | badNodes <- filter (not . (checkNode graph)) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Node has same color as one of it's conflicts" + $$ text " bad nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc) + + -- If this is supposed to be a colored graph, + -- check that all nodes have a color. + | isColored + , badNodes <- filter (\n -> isNothing $ nodeColor n) + $ eltsUFM $ graphMap graph + , not $ null badNodes + = pprPanic "GraphOps.validateGraph" + ( text "Supposably colored graph has uncolored nodes." + $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) + $$ doc ) + + + -- graph looks ok + | otherwise + = graph -- | If this node is colored, check that all the nodes which --- conflict with it have different colors. +-- conflict with it have different colors. checkNode - :: (Uniquable k, Eq color) - => Graph k cls color - -> Node k cls color - -> Bool -- ^ True if this node is ok - + :: (Uniquable k, Eq color) + => Graph k cls color + -> Node k cls color + -> Bool -- ^ True if this node is ok + checkNode graph node - | Just color <- nodeColor node - , Just neighbors <- sequence $ map (lookupNode graph) - $ uniqSetToList $ nodeConflicts node + | Just color <- nodeColor node + , Just neighbors <- sequence $ map (lookupNode graph) + $ uniqSetToList $ nodeConflicts node + + , neighbourColors <- catMaybes $ map nodeColor neighbors + , elem color neighbourColors + = False - , neighbourColors <- catMaybes $ map nodeColor neighbors - , elem color neighbourColors - = False - - | otherwise - = True + | otherwise + = True -- | Slurp out a map of how many nodes had a certain number of conflict neighbours slurpNodeConflictCount - :: Uniquable k - => Graph k cls color - -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) + :: Uniquable k + => Graph k cls color + -> UniqFM (Int, Int) -- ^ (conflict neighbours, num nodes with that many conflicts) slurpNodeConflictCount graph - = addListToUFM_C - (\(c1, n1) (_, n2) -> (c1, n1 + n2)) - emptyUFM - $ map (\node - -> let count = sizeUniqSet $ nodeConflicts node - in (count, (count, 1))) - $ eltsUFM - $ graphMap graph + = addListToUFM_C + (\(c1, n1) (_, n2) -> (c1, n1 + n2)) + emptyUFM + $ map (\node + -> let count = sizeUniqSet $ nodeConflicts node + in (count, (count, 1))) + $ eltsUFM + $ graphMap graph -- | Set the color of a certain node -setColor - :: Uniquable k - => k -> color - -> Graph k cls color -> Graph k cls color - +setColor + :: Uniquable k + => k -> color + -> Graph k cls color -> Graph k cls color + setColor u color - = graphMapModify - $ adjustUFM_C - (\n -> n { nodeColor = Just color }) - u - - -{-# INLINE adjustWithDefaultUFM #-} -adjustWithDefaultUFM - :: Uniquable k - => (a -> a) -> a -> k - -> UniqFM a -> UniqFM a + = graphMapModify + $ adjustUFM_C + (\n -> n { nodeColor = Just color }) + u + + +{-# INLINE adjustWithDefaultUFM #-} +adjustWithDefaultUFM + :: Uniquable k + => (a -> a) -> a -> k + -> UniqFM a -> UniqFM a adjustWithDefaultUFM f def k map - = addToUFM_C - (\old _ -> f old) - map - k def - + = addToUFM_C + (\old _ -> f old) + map + k def + -- Argument order different from UniqFM's adjustUFM {-# INLINE adjustUFM_C #-} -adjustUFM_C - :: Uniquable k - => (a -> a) - -> k -> UniqFM a -> UniqFM a +adjustUFM_C + :: Uniquable k + => (a -> a) + -> k -> UniqFM a -> UniqFM a adjustUFM_C f k map = case lookupUFM map k of - Nothing -> map - Just a -> addToUFM map k (f a) + Nothing -> map + Just a -> addToUFM map k (f a) diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 52415df353..0dc873eb62 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -19,8 +19,8 @@ module ListSetOps ( equivClasses, equivClassesByUniq, -- Remove redudant elts - removeRedundant -- Used in the ghc/InteractiveUI, - -- although not in the compiler itself + removeRedundant -- Used in the ghc/InteractiveUI, + -- although not in the compiler itself ) where #include "HsVersions.h" diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 248f549aa3..b96ae5e063 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -23,7 +23,8 @@ module Outputable ( char, text, ftext, ptext, int, intWithCommas, integer, float, double, rational, - parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, paBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, @@ -387,29 +388,29 @@ renderWithStyle sdoc sty = -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. showSDocOneLine :: SDoc -> String -showSDocOneLine d = - Pretty.showDocWith PageMode +showSDocOneLine d + = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultUserStyle)) showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = - show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) +showSDocForUser unqual doc + = show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) showSDocUnqual :: SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = - show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) +showSDocUnqual d + = show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) showsPrecSDoc :: Int -> SDoc -> ShowS showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) showSDocDump :: SDoc -> String -showSDocDump d = - Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) +showSDocDump d + = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle)) showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = - Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) +showSDocDumpOneLine d + = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) showSDocDebug :: SDoc -> String showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) @@ -444,27 +445,31 @@ float n = docToSDoc $ Pretty.float n double n = docToSDoc $ Pretty.double n rational n = docToSDoc $ Pretty.rational n -parens, braces, brackets, quotes, quote, doubleQuotes, angleBrackets :: SDoc -> SDoc +parens, braces, brackets, quotes, quote, + paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc -parens d = SDoc $ Pretty.parens . runSDoc d -braces d = SDoc $ Pretty.braces . runSDoc d -brackets d = SDoc $ Pretty.brackets . runSDoc d -quote d = SDoc $ Pretty.quote . runSDoc d -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d angleBrackets d = char '<' <> d <> char '>' +paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]") cparen :: Bool -> SDoc -> SDoc cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- 'quotes' encloses something in single quotes... --- but it omits them if the thing ends in a single quote +-- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. quotes d = SDoc $ \sty -> - let pp_d = runSDoc d sty in - case snocView (show pp_d) of - Just (_, '\'') -> pp_d - _other -> Pretty.quotes pp_d + let pp_d = runSDoc d sty + str = show pp_d + in case (str, snocView str) of + (_, Just (_, '\'')) -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc @@ -918,27 +923,27 @@ plural _ = char 's' pprPanic :: String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" -pprPanic = pprAndThen panic +pprPanic = pprDebugAndThen panic pprSorry :: String -> SDoc -> a -- ^ Throw an exception saying "this isn't finished yet" -pprSorry = pprAndThen sorry +pprSorry = pprDebugAndThen sorry pprPgmError :: String -> SDoc -> a -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprPgmError = pprAndThen pgmError +pprPgmError = pprDebugAndThen pgmError pprTrace :: String -> SDoc -> a -> a -- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | opt_NoDebugOutput = x - | otherwise = pprAndThen trace str doc x + | otherwise = pprDebugAndThen trace str doc x pprDefiniteTrace :: String -> SDoc -> a -> a -- ^ Same as pprTrace, but show even if -dno-debug-output is on -pprDefiniteTrace str doc x = pprAndThen trace str doc x +pprDefiniteTrace str doc x = pprDebugAndThen trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' @@ -947,33 +952,31 @@ pprPanicFastInt heading pretty_msg = where doc = text heading <+> pretty_msg - -pprAndThen :: (String -> a) -> String -> SDoc -> a -pprAndThen cont heading pretty_msg = - cont (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [text heading, nest 4 pretty_msg] - -assertPprPanic :: String -> Int -> SDoc -> a --- ^ Panic with an assertation failure, recording the given file and line number. --- Should typically be accessed with the ASSERT family of macros -assertPprPanic file line msg - = panic (show (runSDoc doc (initSDocContext PprDebug))) - where - doc = sep [hsep[text "ASSERT failed! file", - text file, - text "line", int line], - msg] - warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. -- Should typically be accessed with the WARN macros warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x + = pprDebugAndThen trace "WARNING:" doc x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg] + +assertPprPanic :: String -> Int -> SDoc -> a +-- ^ Panic with an assertation failure, recording the given file and line number. +-- Should typically be accessed with the ASSERT family of macros +assertPprPanic file line msg + = pprDebugAndThen panic "ASSERT failed!" doc + where + doc = sep [ hsep [ text "file", text file + , text "line", int line ] + , msg ] + +pprDebugAndThen :: (String -> a) -> String -> SDoc -> a +pprDebugAndThen cont heading pretty_msg + = cont (show (runSDoc doc (initSDocContext PprDebug))) + where + doc = sep [text heading, nest 4 pretty_msg] \end{code} diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 66f51e64e6..47dd7798cd 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -58,6 +58,7 @@ data OS | OSOpenBSD | OSNetBSD | OSKFreeBSD + | OSHaiku deriving (Read, Show, Eq) -- | ARM Instruction Set Architecture and Extensions @@ -91,6 +92,7 @@ osElfTarget OSSolaris2 = True osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False osElfTarget OSKFreeBSD = True +osElfTarget OSHaiku = 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 diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 4ee6e190cc..259689c454 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -20,7 +20,9 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. \begin{code} -{-# OPTIONS -fno-warn-tabs -XGeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-# 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 diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index d09a1ad345..12249d3a2b 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -74,7 +74,6 @@ module Util ( maybeRead, maybeReadFuzzy, -- * IO-ish utilities - createDirectoryHierarchy, doesDirNameExist, getModificationUTCTime, modificationTimeIfExists, @@ -109,10 +108,9 @@ import Data.List hiding (group) import FastTypes #endif -import Control.Monad ( unless, liftM ) +import Control.Monad ( liftM ) import System.IO.Error as IO ( isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, createDirectory, - getModificationTime ) +import System.Directory ( doesDirectoryExist, getModificationTime ) import System.FilePath import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) @@ -1018,16 +1016,6 @@ maybeReadFuzzy str = case reads str of Nothing ----------------------------------------------------------------------------- --- Create a hierarchy of directories - -createDirectoryHierarchy :: FilePath -> IO () -createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack -createDirectoryHierarchy dir = do - b <- doesDirectoryExist dir - unless b $ do createDirectoryHierarchy (takeDirectory dir) - createDirectory dir - ------------------------------------------------------------------------------ -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 1026e95029..f860a4a900 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -47,6 +47,7 @@ buildDataFamInst name' fam_tc vect_tc rhs pat_tys = [mkTyConApp vect_tc (mkTyVarTys tyvars)] rep_tc = buildAlgTyCon name' tyvars + Nothing [] -- no stupid theta rhs rec_flag -- FIXME: is this ok? diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 9b830446c8..9f682a86fd 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -96,6 +96,7 @@ vectTyConDecl tycon name' ; return $ buildAlgTyCon name' -- new name (tyConTyVars tycon) -- keep original type vars + Nothing [] -- no stupid theta rhs' -- new constructor defs rec_flag -- whether recursive diff --git a/configure.ac b/configure.ac index 7e2732c79c..4951467b4d 100644 --- a/configure.ac +++ b/configure.ac @@ -483,7 +483,7 @@ AC_PATH_PROG(PythonCmd,python) dnl ** look for GCC and find out which version dnl Figure out which C compiler to use. Gcc is preferred. -dnl If gcc, make sure it's at least 2.1 +dnl If gcc, make sure it's at least 3.0 dnl FP_GCC_VERSION diff --git a/docs/comm/rts-libs/threaded-rts.html b/docs/comm/rts-libs/threaded-rts.html index 499aeec767..739dc8d58a 100644 --- a/docs/comm/rts-libs/threaded-rts.html +++ b/docs/comm/rts-libs/threaded-rts.html @@ -57,7 +57,7 @@ GhcLibWays += s</pre> <tt>Capability</tt>. The available pool of capabilities is managed by the <tt>Capability</tt> API, described below.</p> - <p>In the threaded runtime, there is only a single <tt>Capabililty</tt> in the + <p>In the threaded runtime, there is only a single <tt>Capability</tt> in the system, indicating that only a single thread can be executing Haskell code at any one time. In the SMP runtime, there can be an arbitrary number of capabilities selectable at runtime with the <tt>+RTS -N<em>n</em></tt> diff --git a/docs/ext-core/Makefile b/docs/ext-core/Makefile deleted file mode 100644 index 603a670662..0000000000 --- a/docs/ext-core/Makefile +++ /dev/null @@ -1,3 +0,0 @@ -dir = docs/users_guide -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk diff --git a/docs/ext-core/a4wide.sty b/docs/ext-core/a4wide.sty deleted file mode 100644 index 9f651505d7..0000000000 --- a/docs/ext-core/a4wide.sty +++ /dev/null @@ -1,39 +0,0 @@ -%NAME: a4wide.sty -% "moretext" document style option. -% Jean-Francois Lamy, July 86 -% -% Redefines the margins so that they are more in line with -% what we are used to see. -% -% [Minimally modified for LaTeX2e, Alexander Holt, August 1994] - -\NeedsTeXFormat{LaTeX2e} -\ProvidesPackage{a4wide}[1994/08/30] -\RequirePackage{a4} - -\ifcase \@ptsize - % mods for 10 pt - \oddsidemargin 0.15 in % Left margin on odd-numbered pages. - \evensidemargin 0.35 in % Left margin on even-numbered pages. - \marginparwidth 1 in % Width of marginal notes. - \oddsidemargin 0.25 in % Note that \oddsidemargin = \evensidemargin - \evensidemargin 0.25 in - \marginparwidth 0.75 in - \textwidth 5.875 in % Width of text line. -\or % mods for 11 pt - \oddsidemargin 0.1 in % Left margin on odd-numbered pages. - \evensidemargin 0.15 in % Left margin on even-numbered pages. - \marginparwidth 1 in % Width of marginal notes. - \oddsidemargin 0.125 in % Note that \oddsidemargin = \evensidemargin - \evensidemargin 0.125 in - \marginparwidth 0.75 in - \textwidth 6.125 in % Width of text line. -\or % mods for 12 pt - \oddsidemargin -10 pt % Left margin on odd-numbered pages. - \evensidemargin 10 pt % Left margin on even-numbered pages. - \marginparwidth 1 in % Width of marginal notes. - \oddsidemargin 0 in % Note that \oddsidemargin = \evensidemargin - \evensidemargin 0 in - \marginparwidth 0.75 in - \textwidth 6.375 true in % Width of text line. -\fi diff --git a/docs/ext-core/code.sty b/docs/ext-core/code.sty deleted file mode 100644 index 3b62685057..0000000000 --- a/docs/ext-core/code.sty +++ /dev/null @@ -1,83 +0,0 @@ - -% I have enclosed code.sty, which achieves 99% of what you want without -% the need for a separate preprocessor. At the start of your document -% you write "\makeatactive". From then on, inline code is written as @\x -% -> x_1 & y@. The only difference with what you are used to, is that -% instead of -% -% @ -% foo :: Int -> Int -% foo = \n -> n+1 -% @ -% -% you have to write -% -% \begin{code} -% foo :: Int -> Int -% foo = \n -> n+1 -% \end{code} -% -% and that you cannot use @ in \section{} and \caption{}. For the paper that occured twice, in which case I had to replace @...@ b y \texttt{...}. -% -% -% code.sty --- nice verbatim mode for code - -\def\icode{% - \relax\ifmmode\hbox\else\leavevmode\null\fi - \bgroup - %\begingroup - \@noligs - \verbatim@font - \verb@eol@error - \let\do\@makeother \dospecials - \@vobeyspaces - \frenchspacing - \@icode} -\def\@icode#1{% - \catcode`#1\active - \lccode`\~`#1% - \lowercase{\let~\icode@egroup}} -\def\icode@egroup{% - %\endgroup} - \egroup} - -% The \makeatactive command: -% makes @ active, in such a way that @...@ behaves as \icode@...@: -{ -\catcode`@=\active -\gdef\makeatactive{ - \catcode`@=\active \def@{\icode@} - % Since @ becomes active, it has to be taken care of in verbatim-modes: - \let\olddospecials\dospecials \def\dospecials{\do\@\olddospecials}} -} -% \gdef\makeatother{\g@remfrom@specials{\@}\@makeother\@} -\gdef\makeatother{\@makeother\@} - -\newcommand\codetabwidth{42pt} -{\catcode`\^^I=\active% -\gdef\@vobeytab{\catcode`\^^I\active\let^^I\@xobeytab}} -\def\@xobeytab{\leavevmode\penalty10000\hskip\codetabwidth} - -\begingroup \catcode `|=0 \catcode `[= 1 -\catcode`]=2 \catcode `\{=12 \catcode `\}=12 -\catcode`\\=12 |gdef|@xcode#1\end{code}[#1|end[code]] -|endgroup -\def\@code{\trivlist \item\relax - \if@minipage\else\vskip\parskip\fi - \leftskip\@totalleftmargin\rightskip\z@skip - \parindent\z@\parfillskip\@flushglue\parskip\z@skip - \@@par - \@tempswafalse - \def\par{% - \if@tempswa - \leavevmode \null \@@par\penalty\interlinepenalty - \else - \@tempswatrue - \ifhmode\@@par\penalty\interlinepenalty\fi - \fi}% - \obeylines \verbatim@font \@noligs - \let\do\@makeother \dospecials - \everypar \expandafter{\the\everypar \unpenalty}% -} -\def\code{\@code \frenchspacing\@vobeytab\@vobeyspaces \@xcode} -\def\endcode{\if@newlist \leavevmode\fi\endtrivlist} diff --git a/docs/ext-core/core.bib b/docs/ext-core/core.bib deleted file mode 100644 index 2c65197a84..0000000000 --- a/docs/ext-core/core.bib +++ /dev/null @@ -1,124 +0,0 @@ -@misc{ghc-user-guide, - howpublished = {\url{http://www.haskell.org/ghc/docs/latest/html/users\_guide/index.html}}, - author = {{The GHC Team}}, - year = 2008, - title = {The {Glorious Glasgow Haskell Compilation System} User's Guide, Version 6.8.2} -} - -http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/FC}}, - author = {{GHC Wiki}}, - year = 2006, - title = {{System FC}: equality constraints and coercions} -} - -@misc{ghc-fc-commentary, - howpublished = {\url{http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/FC}}, - author = {{GHC Wiki}}, - year = 2006, - title = {{System FC}: equality constraints and coercions} -} - -@misc{ghc-api, - howpublished = {\url{http://haskell.org/haskellwiki/GHC/As\_a\_library}}, - author = {{Haskell Wiki}}, - year = 2007, - title = {{Using GHC as a library}} -} - -@book{haskell98, - editor = {Simon {Peyton Jones}}, - publisher = {{Cambridge University Press}}, - address = {Cambridge, UK}, - title = {Haskell 98 Language and Libraries: The Revised Report}, - year = {2003} -} - - - -@inproceedings{system-fc, - address = {New York, NY, USA}, - author = {Martin Sulzmann and Manuel M.T. Chakravarty and Simon {Peyton Jones} and Kevin Donnelly}, - booktitle = {{TLDI '07: Proceedings of the 2007 ACM SIGPLAN International Workshop on Types in Language Design and Implementation}}, - pages = {53--66}, - publisher = {ACM}, - title = {{System F} with type equality coercions}, - url = {http://portal.acm.org/citation.cfm?id=1190324}, - year = {2007} -} - -@inproceedings{gadts, - author = {Simon {Peyton Jones} and Dimitrios Vytiniotis and Stephanie Weirich and Geoffrey Washburn}, - title = {Simple unification-based type inference for {GADTs}}, - booktitle = {{ICFP '06: Proceedings of the 2006 ACM SIGPLAN International Conference on Functional Programming}}, - year = {2006}, - pages = {50--61}, - url = "http://research.microsoft.com/Users/simonpj/papers/gadt/index.htm", - publisher = {ACM}, - address = {New York, NY, USA}, -} - -@inproceedings{ Launchbury94, - author = "John Launchbury and Simon L. {Peyton~Jones}", - title = "Lazy Functional State Threads", - booktitle = "{SIGPLAN} {Conference} on {Programming Language Design and Implementation}", - pages = "24-35", - year = "1994", - url = "http://citeseer.ist.psu.edu/article/launchbury93lazy.html" } - -@inproceedings{ pj:unboxed, - author = "Simon L. {Peyton~Jones} and John Launchbury", - title = "Unboxed Values as First Class Citizens in a Non-strict Functional Language", - booktitle = "Proceedings of the Conference on Functional Programming and Computer Architecture", - month = "26--28 August", - publisher = "Springer-Verlag {LNCS}523", - address = "Cambridge, Massachussets, USA", - editor = "J. Hughes", - pages = "636--666", - year = "1991", - url = "http://citeseer.ist.psu.edu/jones91unboxed.html" } - -@inproceedings{ghc-inliner, - author = "Simon {Peyton~Jones} and Simon Marlow", - title = "Secrets of the {Glasgow Haskell Compiler} inliner", - booktitle = "Workshop on Implementing Declarative Languages", - year = "1999", - location = "Paris, France", - url = "http://research.microsoft.com/Users/simonpj/Papers/inlining/inline.pdf" -} - -@article{ comp-by-trans-scp, - author = "Simon L. {Peyton Jones} and Andr{\'e} L. M. Santos", - title = "A transformation-based optimiser for {Haskell}", - journal = "Science of Computer Programming", - volume = "32", - number = "1--3", - pages = "3--47", - year = "1998", - url = "http://citeseer.ist.psu.edu/peytonjones98transformationbased.html" -} - -@article{ stg-machine, - author = "Simon L. {Peyton Jones}", - title = "Implementing Lazy Functional Languages on Stock Hardware: The {Spineless Tagless G-Machine}", - journal = "Journal of Functional Programming", - volume = "2", - number = "2", - pages = "127-202", - year = "1992", - url = "http://citeseer.ist.psu.edu/peytonjones92implementing.html", -} -@inproceedings{ launchbury93natural, - author = "John Launchbury", - title = "A Natural Semantics for Lazy Evaluation", - booktitle = "Conference Record of the Twentieth Annual {ACM} {SIGPLAN}-{SIGACT} Symposium on Principles of Programming Languages", - address = "Charleston, South Carolina", - pages = "144--154", - year = "1993", - url = "citeseer.ist.psu.edu/launchbury93natural.html" } - -@misc{ghcprim, - howpublished = "\url{http://www.haskell.org/ghc/docs/latest/html/libraries/base/GHC-Prim.html}", - author = {{The GHC Team}}, - year = 2008, - title = "Library documentation: {GHC.Prim}" -}
\ No newline at end of file diff --git a/docs/ext-core/core.tex b/docs/ext-core/core.tex deleted file mode 100644 index 05af0b34c4..0000000000 --- a/docs/ext-core/core.tex +++ /dev/null @@ -1,779 +0,0 @@ -\documentclass[10pt]{article} -\usepackage{a4wide} -\usepackage{code} -\usepackage{natbib} -\usepackage{url} - -\sloppy -\setlength{\parskip}{0.5\baselineskip plus 0.2\baselineskip minus 0.1\baselineskip} -\setlength{\parsep}{\parskip} -\setlength{\topsep}{0cm} -\setlength{\parindent}{0cm} -%\oddsidemargin -0.5 in -%\evensidemargin -0.5 in -%\textwidth 7.375 in - -\newcommand{\derives}{\mbox{$\rightarrow$}} -\newcommand{\orderives}{\mbox{$\mid$}} -\newcommand{\many}[1]{\{ {#1} \}} -\newcommand{\oneormore}[1]{\{ {#1} \}$^{+}$} -\newcommand{\optional}[1]{[ {#1} ]} - -\newcommand{\at}{\texttt{@}} -\newcommand{\att}{@} -\newcommand{\lam}{\texttt{\char`\\}} - -\newcommand{\workingnote}[1]% - {\begin{quote} - \framebox{\parbox{.8 \linewidth} - {\textbf{\textsl{Working note:}} \textsl{#1}}} - \end{quote}} - -%% Can't have more than one paragraph in one of these boxes? WTF -\newcommand{\tjc}[1]% - {\begin{quote} - \framebox{\parbox{.8 \linewidth} - {\textbf{\textsl{tjc:}} \textsl{#1}}} - \end{quote}} - -\begin{document} - -\title{An External Representation for the GHC Core Language\\ (For GHC 6.10)} -\author{Andrew Tolmach, Tim Chevalier ({\tt \{apt,tjc\}@cs.pdx.edu})\\and The GHC Team} - -\maketitle -\makeatactive - -\abstract{ -This document provides a precise definition for the GHC Core language, -so that it can be used to communicate between GHC and new stand-alone -compilation tools such as back-ends or optimizers.\footnote{This is a draft document, which attempts to describe GHC's current -behavior as precisely as possible. Working notes scattered throughout indicate -areas where further work is needed. Constructive comments are very welcome, -both on the presentation, and on ways in which GHC could be improved in order -to simplify the Core story. - -Support for generating external Core (post-optimization) was originally introduced in -GHC 5.02. The definition of external Core in this document reflects the version of -external Core generated by the HEAD (unstable) branch of GHC as of May 3, 2008 (version 6.9), , using the compiler flag -@-fext-core@. We expect that GHC 6.10 will be consistent with this definition.} The definition includes a formal grammar and an informal semantics. -An executable typechecker and interpreter (in Haskell), -which formally embody the static and dynamic semantics, -are available separately. -} - -\section{Introduction} - -The Glasgow Haskell Compiler (GHC) uses an intermediate language, called -``Core,'' as its internal program representation within the compiler's simplification phase. -Core resembles a subset of Haskell, but with explicit type annotations -in the style of the polymorphic lambda calculus (F$_\omega$). - -GHC's front-end translates full Haskell 98 (plus some extensions) into Core. The GHC optimizer then repeatedly transforms Core programs while preserving their meaning. A ``Core Lint'' pass in GHC typechecks Core in between transformation passes (at least when the user enables linting by setting a compiler flag), verifying that transformations preserve type-correctness. Finally, GHC's back-end translates Core into STG-machine code~\citep{stg-machine} and then into -C or native code. - -Two existing papers discuss the original rationale for the design and use of Core~\citep{ghc-inliner,comp-by-trans-scp}, although the (two different) -idealized versions of Core described therein differ in significant ways from the actual Core language in current GHC. In particular, with the advent of GHC support for generalized algebraic datatypes (GADTs)~\citep{gadts} Core was extended beyond its previous F$_\omega$-style incarnation to support type equality constraints and safe coercions, and is now based on a system known as F$_C$~\citep{system-fc}. - - -Researchers interested in writing just {\it part} of a Haskell compiler, -such as a new back-end or a new optimizer pass, might like to use GHC to provide the other parts of the compiler. For example, they -might like to use GHC's front-end to parse, desugar, and type-check source Haskell, -then feeding the resulting code to their own back-end tool. As another example, they might like to use Core as the target language for a front-end compiler of their own design, feeding externally synthesized Core into GHC in order to take advantage of GHC's optimizer, code generator, and run-time system. Without external Core, there are two ways for compiler writers to do this: they can link their code into the -GHC executable, which is an arduous process, or they can use the GHC API~\citep{ghc-api} to do the same task more cleanly. Both ways require new code to be written in Haskell. - -We present a precisely specified external format for Core files. The external format is text-based and human-readable, to promote interoperability and ease of use. We hope this format will make it easier for external developers to use GHC in a modular way. - -It has long been true that GHC prints an ad-hoc textual representation of Core if you set certain compiler flags. But this representation is intended to be read by people who are debugging the compiler, not by other programs. Making Core into a machine-readable, bi-directional communication format requires: - -\begin{enumerate} -\item precisely specifying the external format of Core; - -\item modifying GHC to generate external Core files (post-simplification; as always, users can control the exact transformations GHC does with command-line flags); - -\item modifying GHC to accept external Core files in place of Haskell -source files (users will also be able to control what GHC does to those files with command-line flags). - -\end{enumerate} - -The first two facilities will let developers couple GHC's front-end (parser, -type-checker, desugarer), and optionally its optimizer, with new back-end tools. -The last facility will let developers write new Core-to-Core -transformations as an external tool and integrate them into GHC. It will also -allow new front-ends to generate Core that can be fed into GHC's optimizer or -back-end. - -However, because there are many (undocumented) -idiosyncracies in the way GHC produces Core from source Haskell, it will be hard -for an external tool to produce Core that can be integrated with GHC-produced Core -(e.g., for the Prelude), and we don't aim to support this. Indeed, for the time being, we aim to support only the first two facilities and not the third: we define and implement Core as an external format that GHC can use to communicate with external back-end tools, and defer the larger task of extending GHC to support reading this external format back in. - -This document addresses the first requirement, a formal Core definition, -by proposing a formal grammar for an external representation of Core -(Section~\ref{sec:external}), and -an informal semantics (Section~\ref{sec:informal}). - -GHC supports many type system extensions; the External Core printer built into GHC only supports some of them. However, External Core should be capable of representing any Haskell 98 program, and may be able to represent programs that require certain type system extensions as well. If a program uses unsupported features, GHC may fail to compile it to Core when the @-fext-core@ flag is set, or GHC may successfully compile it to Core, but the external tools will not be able to typecheck or interpret it. - -Formal static and dynamic semantics in the form of an executable typechecker and interpreter -are available separately in the GHC source tree\footnote{\url{http://darcs.haskell.org/ghc}} under @utils/ext-core@. - -\section{External Grammar of Core} -\label{sec:external} - -In designing the external grammar, we have tried to strike a balance among -a number of competing goals, including easy parseability by machines, -easy readability by humans, and adequate structural simplicity to -allow straightforward presentations of the semantics. Thus, we had to make some compromises. Specifically: - -\begin{itemize} -\item In order to avoid explosion of parentheses, we support standard precedences -and short-cuts for expressions, types, and kinds. Thus we had to introduce -multiple non-terminals for each of these syntactic categories, and as a result, -the concrete grammar is longer and more complex than the underlying abstract syntax. - -\item On the other hand, we have kept the grammar simpler by avoiding special syntax for -tuple types and terms. Tuples (both boxed and unboxed) are treated -as ordinary constructors. - -\item All type abstractions and applications are given in full, even though -some of them (e.g., for tuples) could be reconstructed; this means a parser for Core does not have to -reconstruct types.\footnote{These choices are certainly debatable. In particular, keeping -type applications on tuples and case arms considerably increases the size of Core files and -makes them less human-readable, though it allows a Core parser to be simpler.} - -\item The syntax of identifiers is heavily restricted (to just -alphanumerics and underscores); this again makes Core easier to parse but harder to read. - -\end{itemize} - -We use the following notational conventions for syntax: - -\begin{tabular}{ll} -{\it [ pat ]} & optional \\ -{\it \{ pat \}} & zero or more repetitions \\ -{\it \{ pat \}$^{+}$} & one or more repetitions \\ -{\it pat$_1$ \orderives\ pat$_2$} & choice \\ -@fibonacci@ & terminal syntax in typewriter font \\ -\end{tabular} - -\newpage - -{\it -\begin{tabular}{lrclr} -{\rm Module} & module & \derives & - \multicolumn{2}{l}{@\%module@ mident \many{tdef @;@} \many{vdefg @;@}} \\ -\\ -{\rm Type defn.} & tdef & \derives & @%data@ qtycon \many{tbind} @=@ @{@ \optional{cdef \many{@;@ cdef}} @}@ & {\rm algebraic type}\\ - & & \orderives & @%newtype@ qtycon qtycon \many{tbind} @=@ ty & {\rm newtype} \\ -\\ -{\rm Constr. defn.} & cdef & \derives & qdcon \many{@\at@ tbind} \oneormore{aty} \\ -\\ -{\rm Value defn.} & vdefg & \derives & @%rec@ @{@ vdef \many{@;@ vdef} @}@ & {\rm recursive} \\ - & & \orderives & vdef & {\rm non-recursive} \\ - & vdef & \derives & qvar @::@ ty @=@ exp & \\ -\\ -{\rm Atomic expr.} & aexp & \derives & qvar & {\rm variable} \\ - & & \orderives & qdcon & {\rm data constructor}\\ - & & \orderives & lit & {\rm literal} \\ - & & \orderives & @(@ exp @)@ & {\rm nested expr.}\\ -\\ -{\rm Expression} & exp & \derives & aexp & {\rm atomic expresion}\\ - & & \orderives & aexp \oneormore{arg} & {\rm application}\\ - & & \orderives & @\@ \oneormore{binder} @->@ exp & {\rm abstraction}\\ - & & \orderives & @%let@ vdefg @%in@ exp & {\rm local definition}\\ - & & \orderives & @%case@ @(@aty@)@ exp @%of@ vbind @{@ alt \many{@;@ alt} @}@ & {\rm case expression}\\ - & & \orderives & @%cast@ exp aty & {\rm type coercion}\\ - & & \orderives & @%note@ @"@ \many{char} @"@ exp & {\rm expression note}\\ - & & \orderives & @%external ccall@ @"@ \many{char} @"@ aty & {\rm external reference}\\ - & & \orderives & @%dynexternal ccall@ aty & {\rm external reference (dynamic)}\\ - & & \orderives & @%label@ @"@ \many{char} @"@ & {\rm external label} -\\ -\\ -{\rm Argument} & arg & \derives & \at\ aty & {\rm type argument}\\ - & & \orderives & aexp & {\rm value argument} \\ -\\ -{\rm Case alt.} & alt & \derives & qdcon \many {@\at@ tbind} \many{vbind} @->@ exp &{\rm constructor alternative}\\ - & & \orderives & lit @->@ exp & {\rm literal alternative} \\ - & & \orderives & @%_@ @->@ exp & {\rm default alternative} \\ -\\ -{\rm Binder} & binder & \derives & \at\ tbind & {\rm type binder}\\ - & & \orderives & vbind & {\rm value binder}\\ -\\ -{\rm Type binder} & tbind & \derives & tyvar & {\rm implicitly of kind @*@} \\ - & & \orderives & @(@ tyvar @::@ kind @)@ & {\rm explicitly kinded} \\ -\\ -{\rm Value binder} & vbind & \derives & @(@ var @::@ ty @)@ \\ -\\ -{\rm Literal} & lit & \derives & @(@ [@-@] \oneormore{digit} @::@ ty @)@ & {\rm integer} \\ - & & \orderives & @(@ [@-@] \oneormore{digit} @%@ \oneormore{digit} @::@ ty @)@ & {\rm rational} \\ - & & \orderives & @(@ $'$ char $'$ @::@ ty @)@ & {\rm character} \\ - & & \orderives & @(@ @"@ \many{char} @"@ @::@ ty @)@ & {\rm string} \\ -\\ -{\rm Character} & char & \derives & \multicolumn{2}{l}{any ASCII character in range 0x20-0x7E except 0x22,0x27,0x5c}\\ - & & \orderives & @\x@ hex hex & {\rm ASCII code escape sequence} \\ - & hex & \derives & @0@ \orderives \ldots \orderives @9@ \orderives @a@ \orderives \ldots \orderives @f@ \\ -\end{tabular} - -\begin{tabular}{lrclr} -{\rm Atomic type} & aty & \derives & tyvar & {\rm type variable} \\ - & & \orderives & qtycon & {\rm type constructor}\\ - & & \orderives & @(@ ty @)@ & {\rm nested type}\\ -\\ -{\rm Basic type} & bty & \derives & aty & {\rm atomic type}\\ - & & \orderives & bty aty & {\rm type application}\\ - & & \orderives & @%trans@ aty aty & {\rm transitive coercion} \\ - & & \orderives & @%sym@ aty & {\rm symmetric coercion} \\ - & & \orderives & @%unsafe@ aty aty & {\rm unsafe coercion} \\ - & & \orderives & @%left@ aty & {\rm left coercion} \\ - & & \orderives & @%right@ aty & {\rm right coercion} \\ - & & \orderives & @%inst@ aty aty & {\rm instantiation coercion} \\ -\\ -{\rm Type} & ty & \derives & bty & {\rm basic type}\\ - & & \orderives & @%forall@ \oneormore{tbind} @.@ ty & {\rm type abstraction}\\ - & & \orderives & bty @->@ ty & {\rm arrow type construction} \\ - \\ - -{\rm Atomic kind} & akind & \derives & @*@ & {\rm lifted kind}\\ - & & \orderives & @#@ & {\rm unlifted kind}\\ - & & \orderives & @?@ & {\rm open kind}\\ - & & \orderives & bty @:=:@ bty & {\rm equality kind} \\ - & & \orderives & @(@ kind @)@& {\rm nested kind}\\ -\\ -{\rm Kind} & kind & \derives & akind & {\rm atomic kind}\\ - & & \orderives & akind @->@ kind & {\rm arrow kind} \\ -\\ -{\rm Identifier} & mident & \derives & pname @:@ uname & {\rm module} \\ - & tycon & \derives & uname & {\rm type constr.} \\ - & qtycon & \derives & mident @.@ tycon & {\rm qualified type constr.} \\ - & tyvar & \derives & lname & {\rm type variable} \\ - & dcon & \derives & uname & {\rm data constr.} \\ - & qdcon & \derives & mident @.@ dcon & {\rm qualified data constr.} \\ - & var & \derives & lname & {\rm variable} \\ - & qvar & \derives & [ mident @.@ ] var & {\rm optionally qualified variable} \\ -\\ -{\rm Name} & lname & \derives & lower \many{namechar} \\ - & uname & \derives & upper \many{namechar} & \\ - & pname & \derives & \oneormore{namechar} & \\ - & namechar & \derives & lower \orderives\ upper \orderives\ digit \\ - & lower & \derives & @a@ \orderives\ @b@ \orderives\ \ldots \orderives\ @z@ \orderives\ @_@ \\ - & upper & \derives & @A@ \orderives\ @B@ \orderives\ \ldots \orderives\ @Z@ \\ - & digit & \derives & @0@ \orderives\ @1@ \orderives\ \ldots \orderives\ @9@ \\ -\\ -\end{tabular} -} -\section{Informal Semantics} -\label{sec:informal} - -At the term level, Core resembles a explicitly-typed polymorphic lambda calculus (F$_\omega$), with the addition -of local @let@ bindings, algebraic type definitions, constructors, and @case@ expressions, -and primitive types, literals and operators. Its type system is richer than that of System F, supporting explicit type equality coercions and type functions.~\citep{system-fc} - -In this section we concentrate on the less obvious points about Core. - -\subsection{Program Organization and Modules} -\label{sec:modules} - -Core programs are organized into {\em modules}, corresponding directly to source-level Haskell modules. -Each module has a identifying name {\it mident}. A module identifier consists of a {\it package name} followed by a module name, which may be hierarchical: for example, @base:GHC.Base@ is the module identifier for GHC's Base module. Its name is @Base@, and it lives in the @GHC@ hierarchy within the @base@ package. Section 5.8 of the GHC users' guide explains package names~\citep{ghc-user-guide}. In particular, note that a Core program may contain multiple modules with the same (possibly hierarchical) module name that differ in their package names. In some of the code examples that follow, we will omit package names and possibly full hierarchical module names from identifiers for brevity, but be aware that they are always required.\footnote{A possible improvement to the Core syntax would be to add explicit import lists to Core modules, which could be used to specify abbrevations for long qualified names. This would make the code more human-readable.} - -Each module may contain the following kinds of top-level declarations: -\begin{itemize} -\item Algebraic data type declarations, each defining a type constructor and one or more data constructors; -\item Newtype declarations, corresponding to Haskell @newtype@ declarations, each defining a type constructor and a coercion name; and -\item Value declarations, defining the types and values of top-level variables. -\end{itemize} - -No type constructor, data constructor, or top-level value may be declared more than once within a given module. -All the type declarations are (potentially) mutually recursive. Value declarations must be -in dependency order, with explicit grouping of potentially mutually recursive declarations. - - -Identifiers defined in top-level declarations may be {\it external} or {\it internal}. -External identifiers can be referenced from any other module in -the program, using conventional dot notation (e.g., @base:GHC.Base.Bool@, @base:GHC.Base.True@). -Internal identifiers are visible only within the defining module. -All type and data constructors are external, and are always defined and referenced using -fully qualified names (with dots). - -A top-level value is external if it is defined and referenced -using a fully qualified name with a dot (e.g., @main:MyModule.foo = ...@); otherwise, it is internal -(e.g., @bar = ...@). -Note that Core's notion of an external identifier does not necessarily coincide with that of ``exported'' -identifier in a Haskell source module. An identifier can be an external identifier in Core, but not be exported by the original Haskell source module.\footnote{Two examples of such identifiers are: data constructors, and values that potentially appear in an unfolding. For an example of the latter, consider @Main.foo = ... Main.bar ...@, where @Main.foo@ is inlineable. Since @bar@ appears in @foo@'s unfolding, it is defined and referenced with an external name, even if @bar@ was not exported by the original source module.} However, if an identifier was exported by the Haskell source module, it will appear as an external name in Core. - -Core modules have no explicit import or export lists. -Modules may be mutually recursive. Note that because of the latter fact, GHC currently prints out the top-level bindings for every module as a single recursive group, in order to avoid keeping track of dependencies between top-level values within a module. An external Core tool could reconstruct dependencies later, of course. - -There is also an implicitly-defined module @ghc-prim:GHC.Prim@, which exports the ``built-in'' types and values -that must be provided by any implementation of Core (including GHC). Details of this -module are in Section~\ref{sec:prims}. - -A Core {\em program} is a collection of distinctly-named modules that includes a module -called @main:Main@ having an exported value called @main:ZCMain.main@ of type @base:GHC.IOBase.IO a@ (for some type @a@). (Note that the strangely named wrapper for @main@ is the one exception to the rule that qualified names defined within a module @m@ must have module name @m@.) - -Many Core programs will contain library modules, such as @base:GHC.Base@, which implement parts of the Haskell standard library. In principle, these modules are ordinary Haskell modules, with no special status. In practice, the requirement on the type of @main:Main.main@ implies that every program will contain a large subset of -the standard library modules. - -\subsection{Namespaces} -\label{sec:namespaces} - -There are five distinct namespaces: -\begin{enumerate} -\item module identifiers (@mident@), -\item type constructors (@tycon@), -\item type variables (@tyvar@), -\item data constructors (@dcon@), -\item term variables (@var@). -\end{enumerate} - -Spaces (1), (2+3), and (4+5) can be distinguished from each other by context. -To distinguish (2) from (3) and (4) from (5), we require that data and type constructors begin with an upper-case character, and that term and type variables begin with a lower-case character. - -Primitive types and operators are not syntactically distinguished. - -Primitive {\it coercion} operators, of which there are six, {\it are} syntactically distinguished in the grammar. This is because these coercions must be fully applied, and because distinguishing their applications in the syntax makes typechecking easier. - -A given variable (type or term) may have multiple definitions within a module. -However, definitions of term variables never ``shadow'' one another: the scope of the definition -of a given variable never contains a redefinition of the same variable. Type variables may be shadowed. Thus, if a term variable has multiple definitions within a module, all those definitions must be local (let-bound). The only exception -to this rule is that (necessarily closed) types labelling @%external@ expressions may contain -@tyvar@ bindings that shadow outer bindings. - -Core generated by GHC makes heavy use of encoded names, in which the characters @Z@ and @z@ are -used to introduce escape sequences for non-alphabetic characters such as dollar sign @$@ (@zd@), -hash @#@ (@zh@), plus @+@ (@zp@), etc. This is the same encoding used in @.hi@ files and in the -back-end of GHC itself, except that we sometimes change an initial @z@ to @Z@, or vice-versa, -in order to maintain case distinctions. - -Finally, note that hierarchical module names are z-encoded in Core: for example, @base:GHC.Base.foo@ is rendered as @base:GHCziBase.foo@. A parser may reconstruct the module hierarchy, or regard @GHCziBase@ as a flat name. -\subsection{Types and Kinds} -\label{sec:typesandkinds} - -In Core, all type abstractions and applications are explicit. This make it easy to -typecheck any (closed) fragment of Core code. An full executable typechecker is available separately. - -\subsubsection{Types} -Types are described by type expressions, which -are built from named type constructors and type variables -using type application and universal quantification. -Each type constructor has a fixed arity $\geq 0$. -Because it is so widely used, there is -special infix syntax for the fully-applied function type constructor (@->@). -(The prefix identifier for this constructor is @ghc-prim:GHC.Prim.ZLzmzgZR@; this should -only appear in unapplied or partially applied form.) - -There are also a number of other primitive type constructors (e.g., @Intzh@) that -are predefined in the @GHC.Prim@ module, but have no special syntax. -@%data@ and @%newtype@ declarations introduce additional type constructors, as described below. -Type constructors are distinguished solely by name. - -\subsubsection{Coercions} - -A type may also be built using one of the primitive coercion operators, as described in Section~\ref{sec:namespaces}. For details on the meanings of these operators, see the System FC paper~\citep{system-fc}. Also see Section~\ref{sec:newtypes} for examples of how GHC uses coercions in Core code. - -\subsubsection{Kinds} -As described in the Haskell definition, it is necessary to distinguish -well-formed type-expressions by classifying them into different {\it kinds}~\citep[p. 41]{haskell98}. -In particular, Core explicitly records the kind of every bound type variable. - -In addition, Core's kind system includes equality kinds, as in System FC~\citep{system-fc}. An application of a built-in coercion, or of a user-defined coercion as introduced by a newtype declaration, has an equality kind. -\subsubsection{Lifted and Unlifted Types} -Semantically, a type is {\it lifted} if and only if it has bottom as an element. We need to distinguish them because operationally, terms with lifted types may be represented by closures; terms with unlifted types must not be represented by closures, which implies that any unboxed value is necessarily unlifted. We distinguish between lifted and unlifted types by ascribing them different kinds. - -Currently, all the primitive types are unlifted -(including a few boxed primitive types such as @ByteArrayzh@). -Peyton Jones and Launchbury~[\citeyear{pj:unboxed}] described the ideas behind unboxed and unlifted types. - -\subsubsection{Type Constructors; Base Kinds and Higher Kinds} -Every type constructor has a kind, depending on its arity and whether it or its arguments are lifted. - -Term variables can only be assigned types that have base kinds: the base kinds are @*@,@#@, and @?@. The three base kinds distinguish the liftedness of the types they classify: -@*@ represents lifted types; @#@ represents unlifted types; and @?@ is the ``open'' kind, representing a type that may be either lifted or unlifted. Of these, only @*@ ever -appears in Core type declarations generated from user code; the other two are needed to describe -certain types in primitive (or otherwise specially-generated) code (which, after optimization, could potentially appear anywhere). - -In particular, no top-level identifier (except in @ghc-prim:GHC.Prim@) has a type of kind @#@ or @?@. - -Nullary type constructors have base kinds: for example, the type @Int@ has kind @*@, and @Int#@ has kind @#@. - -Non-nullary type constructors have higher kinds: kinds that have the form $k_1 @->@ k_2$, -where $k_1$ and $k_2$ are kinds. For example, the function type constructor -@->@ has kind @* -> (* -> *)@. Since Haskell allows abstracting over type -constructors, type variables may have higher kinds; however, much more commonly they have kind @*@, so that is the default if a type binder omits a kind. - -\subsubsection{Type Synonyms and Type Equivalence} -There is no mechanism for defining type synonyms (corresponding to -Haskell @type@ declarations). - -Type equivalence is just syntactic equivalence on type expressions -(of base kinds) modulo: - -\begin{itemize} -\item alpha-renaming of variables bound in @%forall@ types; -\item the identity $a$ @->@ $b$ $\equiv$ @ghc-prim:GHC.Prim.ZLzmzgZR@ $a$ $b$ -\end{itemize} - -\subsection{Algebraic data types} - -Each @data@ declaration introduces a new type constructor and a set of one or -more data constructors, normally corresponding directly to a source Haskell @data@ declaration. -For example, the source declaration -\begin{code} -data Bintree a = - Fork (Bintree a) (Bintree a) -| Leaf a -\end{code} -might induce the following Core declaration -\begin{code} -%data Bintree a = { - Fork (Bintree a) (Bintree a); - Leaf a)} -\end{code} -which introduces the unary type constructor @Bintree@ of kind @*->*@ and two data constructors with types -\begin{code} -Fork :: %forall a . Bintree a -> Bintree a -> Bintree a -Leaf :: %forall a . a -> Bintree a -\end{code} -We define the {\it arity} of each data constructor to be the number of value arguments it takes; -e.g. @Fork@ has arity 2 and @Leaf@ has arity 1. - -For a less conventional example illustrating the possibility of higher-order kinds, the Haskell source declaration -\begin{code} -data A f a = MkA (f a) -\end{code} -might induce the Core declaration -\begin{code} -%data A (f::*->*) a = { MkA (f a) } -\end{code} -which introduces the constructor -\begin{code} -MkA :: %forall (f::*->*) a . (f a) -> (A f) a -\end{code} - -GHC (like some other Haskell implementations) supports an extension to Haskell98 -for existential types such as -\begin{code} -data T = forall a . MkT a (a -> Bool) -\end{code} -This is represented by the Core declaration -\begin{code} -%data T = {MkT @a a (a -> Bool)} -\end{code} -which introduces the nullary type constructor @T@ and the data constructor -\begin{code} -MkT :: %forall a . a -> (a -> Bool) -> T -\end{code} -In general, existentially quantified variables appear as extra univerally -quantified variables in the data contructor types. -An example of how to construct and deconstruct values of type @T@ is shown in -Section~\ref{sec:exprs}. - -\subsection{Newtypes} -\label{sec:newtypes} - -Each Core @%newtype@ declaration introduces a new type constructor and an associated -representation type, corresponding to a source Haskell @newtype@ -declaration. However, unlike in source Haskell, a @%newtype@ declaration does not introduce any data constructors. - -Each @%newtype@ declaration also introduces a new coercion (syntactically, just another type constructor) that implies an axiom equating the type constructor, applied to any type variables bound by the @%newtype@, to the representation type. - -For example, the Haskell fragment -\begin{code} -newtype U = MkU Bool -u = MkU True -v = case u of - MkU b -> not b -\end{code} -might induce the Core fragment -\begin{code} -%newtype U ZCCoU = Bool; -u :: U = %cast (True) - ((%sym ZCCoU)); -v :: Bool = not (%cast (u) ZCCoU); -\end{code} - -The newtype declaration implies that the types {\tt U} and {\tt Bool} have equivalent representations, and the coercion axiom {\tt ZCCoU} provides evidence that {\tt U} is equivalent to {\tt Bool}. Notice that in the body of {\tt u}, the boolean value {\tt True} is cast to type {\tt U} using the primitive symmetry rule applied to {\tt ZCCoU}: that is, using a coercion of kind {\tt Bool :=: U}. And in the body of {\tt v}, {\tt u} is cast back to type {\tt Bool} using the axiom {\tt ZCCoU}. - -Notice that the {\tt case} in the Haskell source code above translates to a {\tt cast} in the corresponding Core code. That is because operationally, a {\tt case} on a value whose type is declared by a {\tt newtype} declaration is a no-op. Unlike a {\tt case} on any other value, such a {\tt case} does no evaluation: its only function is to coerce its scrutinee's type. - -Also notice that unlike in a previous draft version of External Core, there is no need to handle recursive newtypes specially. -\subsection{Expression Forms} -\label{sec:exprs} - -Variables and data constructors are straightforward. - -Literal ({\it lit}) expressions consist of a literal value, in one of four different formats, -and a (primitive) type annotation. Only certain combinations of format and type -are permitted; see Section~\ref{sec:prims}. The character and string formats can describe only -8-bit ASCII characters. - -Moreover, because the operational semantics for Core interprets strings as C-style null-terminated -strings, strings should not contain embedded nulls. - -In Core, value applications, type applications, value abstractions, and type abstractions are all explicit. To tell them apart, type arguments in applications -and formal type arguments in abstractions are preceded by an \at\ symbol. (In abstractions, -the \at\ plays essentially the same role as the more usual $\Lambda$ symbol.) -For example, the Haskell source declaration -\begin{code} -f x = Leaf (Leaf x) -\end{code} -might induce the Core declaration -\begin{code} -f :: %forall a . a -> BinTree (BinTree a) = - \ @a (x::a) -> Leaf @(Bintree a) (Leaf @a x) -\end{code} - -Value applications may be of user-defined functions, data constructors, or primitives. -None of these sorts of applications are necessarily saturated. - -Note that the arguments of type applications are not always of kind @*@. For example, -given our previous definition of type @A@: -\begin{code} -data A f a = MkA (f a) -\end{code} -the source code -\begin{code} -MkA (Leaf True) -\end{code} -becomes -\begin{code} -(MkA @Bintree @Bool) (Leaf @Bool True) -\end{code} - -Local bindings, of a single variable or of a set of mutually recursive variables, -are represented by @%let@ expressions in the usual way. - -By far the most complicated expression form is @%case@. -@%case@ expressions are permitted over values of any type, although they will normally -be algebraic or primitive types (with literal values). -Evaluating a @%case@ forces the evaluation of the expression being -tested (the ``scrutinee''). The value of the scrutinee is bound to the variable -following the @%of@ keyword, which is in scope in all alternatives; -this is useful when the scrutinee is a non-atomic -expression (see next example). The scrutinee is preceded by the type of the entire @%case@ expression: that is, the result type that all of the @%case@ alternatives have (this is intended to make type reconstruction easier in the presence of type equality coercions). - -In an algebraic @%case@, all the case alternatives must be -labeled with distinct data constructors from the algebraic type, followed by -any existential type variable bindings (see below), and -typed term variable bindings corresponding to the data constructor's -arguments. The number of variables must match the data constructor's arity. - -For example, the following Haskell source expression -\begin{code} -case g x of - Fork l r -> Fork r l - t@(Leaf v) -> Fork t t -\end{code} -might induce the Core expression -\begin{code} -%case ((Bintree a)) g x %of (t::Bintree a) - Fork (l::Bintree a) (r::Bintree a) -> - Fork @a r l - Leaf (v::a) -> - Fork @a t t -\end{code} - -When performing a @%case@ over a value of an existentially-quantified algebraic -type, the alternative must include extra local type bindings -for the existentially-quantified variables. For example, given -\begin{code} -data T = forall a . MkT a (a -> Bool) -\end{code} -the source -\begin{code} -case x of - MkT w g -> g w -\end{code} -becomes -\begin{code} -%case x %of (x'::T) - MkT @b (w::b) (g::b->Bool) -> g w -\end{code} - -In a @%case@ over literal alternatives, -all the case alternatives must be distinct literals of the same primitive type. - -The list of alternatives may begin with a -default alternative labeled with an underscore (@%_@), whose right-hand side will be evaluated if -none of the other alternatives match. The default is optional except for in a case -over a primitive type, or when there are no other alternatives. -If the case is over neither an -algebraic type nor a primitive type, then the list of alternatives must contain a default alternative and nothing else. -For algebraic cases, the set of alternatives -need not be exhaustive, even if no default is given; if alternatives are missing, -this implies that GHC has deduced that they cannot occur. - -@%cast@ is used to manipulate newtypes, as described in Section~\ref{sec:newtypes}. The @%cast@ expression takes an expression and a coercion: -syntactically, the coercion is an arbitrary type, but it must have an -equality kind. In an expression @(cast e co)@, if @e :: T@ and @co@ -has kind @T :=: U@, then the overall expression has type -@U@~\citep{ghc-fc-commentary}. Here, @co@ must be a coercion whose left-hand side is @T@. - -Note -that unlike the @%coerce@ expression that existed in previous versions -of Core, this means that @%cast@ is (almost) type-safe: the coercion -argument provides evidence that can be verified by a -typechecker. There are still unsafe @%cast@s, corresponding to the -unsafe @%coerce@ construct that existed in old versions of Core, -because there is a primitive unsafe coercion type that -can be used to cast arbitrary types to each other. GHC uses this for -such purposes as coercing the return type of a function (such as -error) which is guaranteed to never return: -\begin{code} -case (error "") of - True -> 1 - False -> 2 -\end{code} -becomes: -\begin{code} - %cast (error @ Bool (ZMZN @ Char)) - (%unsafe Bool Integer); -\end{code} -@%cast@ has no operational meaning and is only used in typechecking. - - - -A @%note@ expression carries arbitrary internal information that GHC finds interesting. The information is encoded as a string. Expression notes currently generated by GHC -include the inlining pragma (@InlineMe@) and cost-center labels for profiling. - -A @%external@ expression denotes an external identifier, which has -the indicated type (always expressed in terms of Haskell primitive types). External Core supports two kinds of external calls: @%external@ and @%dynexternal@. Only the former is supported by the current set of stand-alone Core tools. In addition, there is a @%label@ construct which GHC may generate but which the Core tools do not support. - -The present syntax for externals is sufficient for describing C functions and labels. -Interfacing to other languages may require additional information or a different interpretation -of the name string. - - -\subsection{Expression Evaluation} -\label{sec:evaluation} - -The dynamic semantics of Core are defined on the type-erasure of the program: for example, we ignore all type abstractions and applications. The denotational semantics of -the resulting type-free program are just the conventional ones for a call-by-name -language, in which expressions are only evaluated on demand. -But Core is intended to be a call-by-{\it{need}} language, in which -expressions are only evaluated {\it once}. To express the sharing behavior -of call-by-need, we give an operational model in the style of Launchbury~\citep{launchbury93natural}. - -This section describes the model informally; a more formal semantics is -separately available as an executable interpreter. - -To simplify the semantics, we consider only ``well-behaved'' Core programs in which -constructor and primitive applications are fully saturated, and in which -non-trivial expresssions of unlifted kind (@#@) appear only as scrutinees -in @%case@ expressions. Any program can easily be put into this form; -a separately available preprocessor illustrates how. -In the remainder of this section, we use ``Core'' to mean ``well-behaved'' Core. - -Evaluating a Core expression means reducing it to {\it weak-head normal form (WHNF)}, -i.e., a primitive value, lambda abstraction, or fully-applied data constructor. Evaluating a program means evaluating the expression @main:ZCMain.main@. - -To make sure that expression evaluation is shared, we -make use of a {\it heap}, which contains {\it heap entries}. A heap entry can be: -\begin{itemize} -\item A {\em thunk}, representing an unevaluated expression, also known as a {\em suspension}. - -\item A {\em WHNF}, representing an evaluated expression. The result of evaluating a thunk is a WHNF. A WHNF is always a closure (corresponding to a lambda abstraction in the source program) or a data constructor application: computations over primitive types are never suspended. -\end{itemize} - -{\it Heap pointers} point to heap entries: at different times, the same heap pointer can point to either a thunk or a WHNF, because the run-time system overwrites thunks with WHNFs as computation proceeds. - -The suspended computation that a thunk represents might represent evaluating one of three different kinds of expression. The run-time system allocates a different kind of thunk depending on what kind of expression it is: -\begin{itemize} -\item A thunk for a value definition has a group of suspended defining expressions, along with a list of bindings between defined names and heap pointers to those suspensions. (A value definition may be a recursive group of definitions or a single non-recursive definition, and it may be top-level (global) or @let@-bound (local)). - -\item A thunk for a function application (where the function is user-defined) has a suspended actual argument expression, and a binding between the formal argument and a heap pointer to that suspension. - -\item A thunk for a constructor application has a suspended actual argument expression; the entire constructed value has a heap pointer to that suspension embedded in it. -\end{itemize} - -As computation proceeds, copies of the heap pointer for a given thunk propagate through the executing program. -When another computation demands the result of that thunk, the thunk is {\it forced}: the run-time system computes the thunk's result, yielding a WHNF, and overwrites the heap entry for the thunk with the WHNF. Now, all copies of the heap pointer point to the new heap entry: a WHNF. Forcing occurs -only in the context of -\begin{itemize} -\item evaluating the operator expression of an application; - -\item evaluating the scrutinee of a @case@ expression; or - -\item evaluating an argument to a primitive or external function application -\end{itemize} - -When no pointers to a heap entry (whether it is a thunk or WHNF) remain, the garbage collector can reclaim the space it uses. We assume this happens implicitly. - -With the exception of functions, arrays, and mutable variables, we intend that values of all primitive types -should be held {\it unboxed}: they should not be heap-allocated. This does not violate call-by-need semantics: all -primitive types are {\it unlifted}, which means that values of those types must be evaluated strictly. Unboxed tuple types are not heap-allocated either. - -Certain primitives and @%external@ functions cause side-effects to state threads or to the real world. -Where the ordering of these side-effects matters, Core already forces this order with data dependencies on the pseudo-values representing the threads. - -An implementation must specially support the @raisezh@ and @handlezh@ primitives: for example, by using a handler stack. -Again, real-world threading guarantees that they will execute in the correct order. - -\section{Primitive Module} -\label{sec:prims} - -The semantics of External Core rely on the contents and informal semantics of the primitive module @ghc-prim:GHC.Prim@. -Nearly all the primitives are required in order to cover GHC's implementation of the Haskell98 -standard prelude; the only operators that can be completely omitted are those supporting the byte-code interpreter, -parallelism, and foreign objects. Some of the concurrency primitives are needed, but can be -given degenerate implementations if it desired to target a purely sequential backend (see Section~\ref{sec:sequential}). - -In addition to these primitives, a large number of C library functions are required to implement -the full standard Prelude, particularly to handle I/O and arithmetic on less usual types. - -For a full listing of the names and types of the primitive operators, see the GHC library documentation~\citep{ghcprim}. - - -\subsection{Non-concurrent Back End} -\label{sec:sequential} - -The Haskell98 standard prelude doesn't include any concurrency support, but GHC's -implementation of it relies on the existence of some concurrency primitives. However, -it never actually forks multiple threads. Hence, the concurrency primitives can -be given degenerate implementations that will work in a non-concurrent setting, -as follows: -\begin{itemize} -\item @ThreadIdzh@ can be represented -by a singleton type, whose (unique) value is returned by @myThreadIdzh@. - -\item @forkzh@ can just die with an ``unimplemented'' message. - -\item @killThreadzh@ and @yieldzh@ can also just die ``unimplemented'' since -in a one-thread world, the only thread a thread can kill is itself, and -if a thread yields the program hangs. - -\item @MVarzh a@ can be represented by @MutVarzh (Maybe a)@; -where a concurrent implementation would block, the sequential implementation can -just die with a suitable message (since no other thread exists to unblock it). - -\item @waitReadzh@ and @waitWritezh@ can be implemented using a @select@ with no timeout. -\end{itemize} - -\subsection{Literals} - -Only the following combination of literal forms and types are permitted: - -\begin{tabular}{|l|l|l|} -\hline -Literal form & Type & Description \\ -\hline -integer & @Intzh@ & Int \\ -% & @Int32zh@ & Int32 \\ -% & @Int64zh@ & Int64 \\ - & @Wordzh@ & Word \\ -% & @Word32zh@ & Word32 \\ -% & @Word64zh@ & Word64 \\ - & @Addrzh@ & Address \\ - & @Charzh@ & Unicode character code \\ -rational & @Floatzh@ & Float \\ - & @Doublezh@ & Double \\ -character & @Charzh@ & Unicode character specified by ASCII character\\ -string & @Addrzh@ & Address of specified C-format string \\ -\hline -\end{tabular} - -\bibliography{core} -\bibliographystyle{abbrvnat} - -\end{document} diff --git a/docs/ext-core/ghc.mk b/docs/ext-core/ghc.mk deleted file mode 100644 index 47e56c099b..0000000000 --- a/docs/ext-core/ghc.mk +++ /dev/null @@ -1,15 +0,0 @@ - -ifeq "$(LATEX_DOCS)" "YES" -$(eval $(call all-target,docs/ext-core,docs/ext-core/core.pdf)) - -INSTALL_DOCS += docs/ext-core/core.pdf -endif - -ifneq "$(BINDIST)" "YES" -docs/ext-core/core.pdf: docs/ext-core/core.tex - cd docs/ext-core && $(PDFLATEX) core.tex - cd docs/ext-core && $(BIBTEX) core - cd docs/ext-core && $(PDFLATEX) core.tex - cd docs/ext-core && $(PDFLATEX) core.tex -endif - diff --git a/docs/users_guide/external_core.xml b/docs/users_guide/external_core.xml new file mode 100644 index 0000000000..faf7148f20 --- /dev/null +++ b/docs/users_guide/external_core.xml @@ -0,0 +1,1807 @@ +<?xml version="1.0" encoding="utf-8"?> + +<!-- +This document is a semi-automatic conversion of docs/ext-core/core.tex to DocBook using + +1. `htlatex` to convert LaTeX to HTML +2. `pandoc` to convert HTML to DocBook +3. extensive manual work by James H. Fisher (jameshfisher@gmail.com) +--> + +<!-- +TODO: + +* Replace "java" programlisting with "ghccore" +("ghccore" is not recognized by highlighters, +causing some generators to fail). + +* Complete bibliography entries with journal titles; +I am unsure of the proper DocBook elements. + +* Integrate this file with the rest of the Users' Guide. +--> + + +<chapter id="an-external-representation-for-the-ghc-core-language-for-ghc-6.10"> + <title>An External Representation for the GHC Core Language (For GHC 6.10)</title> + + <para>Andrew Tolmach, Tim Chevalier ({apt,tjc}@cs.pdx.edu) and The GHC Team</para> + + <abstract> + <para>This document provides a precise definition for the GHC Core + language, so that it can be used to communicate between GHC and new + stand-alone compilation tools such as back-ends or + optimizers.<footnote> + <para>This is a draft document, which attempts + to describe GHC’s current behavior as precisely as possible. Working + notes scattered throughout indicate areas where further work is + needed. Constructive comments are very welcome, both on the + presentation, and on ways in which GHC could be improved in order to + simplify the Core story.</para> + + <para>Support for generating external Core (post-optimization) was + originally introduced in GHC 5.02. The definition of external Core in + this document reflects the version of external Core generated by the + HEAD (unstable) branch of GHC as of May 3, 2008 (version 6.9), using + the compiler flag <code>-fext-core</code>. We expect that GHC 6.10 will be + consistent with this definition.</para> + </footnote> + The definition includes a formal grammar and an informal semantics. + An executable typechecker and interpreter (in Haskell), which + formally embody the static and dynamic semantics, are available + separately.</para> + + </abstract> + + <section id="introduction"> + <title>Introduction</title> + + <para>The Glasgow Haskell Compiler (GHC) uses an intermediate language, + called <quote>Core,</quote> as its internal program representation within the + compiler’s simplification phase. Core resembles a subset of + Haskell, but with explicit type annotations in the style of the + polymorphic lambda calculus (F<subscript>ω</subscript>).</para> + + <para>GHC’s front-end translates full Haskell 98 (plus some extensions) + into Core. The GHC optimizer then repeatedly transforms Core + programs while preserving their meaning. A <quote>Core Lint</quote> pass in GHC + typechecks Core in between transformation passes (at least when + the user enables linting by setting a compiler flag), verifying + that transformations preserve type-correctness. Finally, GHC’s + back-end translates Core into STG-machine code <citation>stg-machine</citation> and then into C + or native code.</para> + + <para>Two existing papers discuss the original rationale for the design + and use of Core <citation>ghc-inliner,comp-by-trans-scp</citation>, although the (two different) idealized + versions of Core described therein differ in significant ways from + the actual Core language in current GHC. In particular, with the + advent of GHC support for generalized algebraic datatypes (GADTs) + <citation>gadts</citation> Core was extended beyond its previous + F<subscript>ω</subscript>-style incarnation to support type + equality constraints and safe coercions, and is now based on a + system known as F<subscript>C</subscript> <citation>system-fc</citation>.</para> + + <para>Researchers interested in writing just <emphasis>part</emphasis> of a Haskell compiler, + such as a new back-end or a new optimizer pass, might like to use + GHC to provide the other parts of the compiler. For example, they + might like to use GHC’s front-end to parse, desugar, and + type-check source Haskell, then feeding the resulting code to + their own back-end tool. As another example, they might like to + use Core as the target language for a front-end compiler of their + own design, feeding externally synthesized Core into GHC in order + to take advantage of GHC’s optimizer, code generator, and run-time + system. Without external Core, there are two ways for compiler + writers to do this: they can link their code into the GHC + executable, which is an arduous process, or they can use the GHC + API <citation>ghc-api</citation> to do the same task more cleanly. Both ways require new + code to be written in Haskell.</para> + + <para>We present a precisely specified external format for Core files. + The external format is text-based and human-readable, to promote + interoperability and ease of use. We hope this format will make it + easier for external developers to use GHC in a modular way.</para> + + <para>It has long been true that GHC prints an ad-hoc textual + representation of Core if you set certain compiler flags. But this + representation is intended to be read by people who are debugging + the compiler, not by other programs. Making Core into a + machine-readable, bi-directional communication format requires: + + <orderedlist> + <listitem> + precisely specifying the external format of Core; + </listitem> + <listitem> + modifying GHC to generate external Core files + (post-simplification; as always, users can control the exact + transformations GHC does with command-line flags); + </listitem> + <listitem> + modifying GHC to accept external Core files in place of + Haskell source files (users will also be able to control what + GHC does to those files with command-line flags). + </listitem> + </orderedlist> + </para> + + <para>The first two facilities will let developers couple GHC’s + front-end (parser, type-checker, desugarer), and optionally its + optimizer, with new back-end tools. The last facility will let + developers write new Core-to-Core transformations as an external + tool and integrate them into GHC. It will also allow new + front-ends to generate Core that can be fed into GHC’s optimizer + or back-end.</para> + + <para>However, because there are many (undocumented) idiosyncracies in + the way GHC produces Core from source Haskell, it will be hard for + an external tool to produce Core that can be integrated with + GHC-produced Core (e.g., for the Prelude), and we don’t aim to + support this. Indeed, for the time being, we aim to support only + the first two facilities and not the third: we define and + implement Core as an external format that GHC can use to + communicate with external back-end tools, and defer the larger + task of extending GHC to support reading this external format back + in.</para> + + <para>This document addresses the first requirement, a formal Core + definition, by proposing a formal grammar for an + <link linkend="external-grammar-of-core">external representation of Core</link>, + and an <link linkend="informal-semantics">informal semantics</link>.</para> + + <para>GHC supports many type system extensions; the External Core + printer built into GHC only supports some of them. However, + External Core should be capable of representing any Haskell 98 + program, and may be able to represent programs that require + certain type system extensions as well. If a program uses + unsupported features, GHC may fail to compile it to Core when the + -fext-core flag is set, or GHC may successfully compile it to + Core, but the external tools will not be able to typecheck or + interpret it.</para> + + <para>Formal static and dynamic semantics in the form of an executable + typechecker and interpreter are available separately in the GHC + source tree + <footnote><ulink url="http://darcs.haskell.org/ghc">http://darcs.haskell.org/ghc</ulink></footnote> + under <code>utils/ext-core</code>.</para> + + </section> + <section id="external-grammar-of-core"> + <title>External Grammar of Core</title> + + <para>In designing the external grammar, we have tried to strike a + balance among a number of competing goals, including easy + parseability by machines, easy readability by humans, and adequate + structural simplicity to allow straightforward presentations of + the semantics. Thus, we had to make some compromises. + Specifically:</para> + + <itemizedlist> + <listitem>In order to avoid explosion of parentheses, we support + standard precedences and short-cuts for expressions, types, + and kinds. Thus we had to introduce multiple non-terminals for + each of these syntactic categories, and as a result, the + concrete grammar is longer and more complex than the + underlying abstract syntax.</listitem> + + <listitem>On the other hand, we have kept the grammar simpler by + avoiding special syntax for tuple types and terms. Tuples + (both boxed and unboxed) are treated as ordinary constructors.</listitem> + + <listitem>All type abstractions and applications are given in full, even + though some of them (e.g., for tuples) could be reconstructed; + this means a parser for Core does not have to reconstruct + types.<footnote> + These choices are certainly debatable. In + particular, keeping type applications on tuples and case arms + considerably increases the size of Core files and makes them less + human-readable, though it allows a Core parser to be simpler. + </footnote></listitem> + + <listitem>The syntax of identifiers is heavily restricted (to just + alphanumerics and underscores); this again makes Core easier + to parse but harder to read.</listitem> + </itemizedlist> + + <para>We use the following notational conventions for syntax: + + <informaltable frame="none"> + <tgroup cols='2' align='left' colsep="0" rowsep="0"> + <tbody> + <row> + <entry>[ pat ]</entry> + <entry>optional</entry> + </row> + + <row> + <entry>{ pat }</entry> + <entry>zero or more repetitions</entry> + </row> + + <row> + <entry> + { pat }<superscript>+</superscript> + </entry> + <entry>one or more repetitions</entry> + </row> + + <row> + <entry> + pat<subscript>1</subscript> ∣ pat<subscript>2</subscript> + </entry> + <entry>choice</entry> + </row> + + <row> + <entry> + <code>fibonacci</code> + </entry> + <entry>terminal syntax in typewriter font</entry> + </row> + </tbody> + </tgroup> + </informaltable> + </para> + + <informaltable frame="none" colsep="0" rowsep="0"> + <tgroup cols='5'> + <colspec colname="cat" align="left" colwidth="3*" /> + <colspec colname="lhs" align="right" colwidth="2*" /> + <colspec align="center" colwidth="*" /> + <colspec colname="rhs" align="left" colwidth="10*" /> + <colspec colname="name" align="right" colwidth="6*" /> + <tbody> + <row rowsep="1"> + <entry>Module</entry> + <entry>module</entry> + <entry>→</entry> + <entry> + <code>%module</code> mident { tdef ; }{ vdefg ; } + </entry> + <entry></entry> + </row> + + <row> + <entry morerows="1" valign="top">Type defn.</entry> + <entry morerows="1" valign="top">tdef</entry> + <entry>→</entry> + <entry> + <code>%data</code> qtycon { tbind } <code>= {</code> [ cdef {<code>;</code> cdef } ] <code>}</code> + </entry> + <entry>algebraic type</entry> + </row> + <row rowsep="1"> + <entry>∣</entry> + <entry> + <code>%newtype</code> qtycon qtycon { tbind } <code>=</code> ty + </entry> + <entry>newtype</entry> + </row> + + <row rowsep="1"> + <entry>Constr. defn.</entry> + <entry>cdef</entry> + <entry>→</entry> + <entry> + qdcon { <code>@</code> tbind }{ aty }<superscript>+</superscript> + </entry> + </row> + + <row> + <entry morerows="2" valign="top">Value defn.</entry> + <entry morerows="1" valign="top">vdefg</entry> + <entry>→</entry> + <entry><code>%rec {</code> vdef { <code>;</code> vdef } <code>}</code></entry> + <entry>recursive</entry> + </row> + + <row> + <entry>∣</entry> + <entry>vdef</entry> + <entry>non-recursive</entry> + </row> + + <row rowsep="1"> + <entry>vdef</entry> + <entry>→</entry> + <entry>qvar <code>::</code> ty <code>=</code> exp</entry> + <entry></entry> + </row> + + <row> + <entry morerows="3" valign="top">Atomic expr.</entry> + <entry morerows="3" valign="top">aexp</entry> + <entry>→</entry> + <entry>qvar</entry> + <entry>variable</entry> + </row> + + <row> + <entry>∣</entry> + <entry>qdcon</entry> + <entry>data constructor</entry> + </row> + + <row> + <entry>∣</entry> + <entry>lit</entry> + <entry>literal</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>(</code> exp <code>)</code></entry> + <entry>nested expr.</entry> + </row> + + <row> + <entry morerows="9" valign="top">Expression</entry> + <entry morerows="9" valign="top">exp</entry> + <entry>→</entry> + <entry>aexp</entry> + <entry>atomic expresion</entry> + </row> + + <row> + <entry>∣</entry> + <entry>aexp { arg }<superscript>+</superscript></entry> + <entry>application</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>\</code> { binder }<superscript>+</superscript> &arw; exp</entry> + <entry>abstraction</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%let</code> vdefg <code>%in</code> exp</entry> + <entry>local definition</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%case (</code> aty <code>)</code> exp <code>%of</code> vbind <code>{</code> alt { <code>;</code> alt } <code>}</code></entry> + <entry>case expression</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%cast</code> exp aty</entry> + <entry>type coercion</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%note</code> " { char } " exp</entry> + <entry>expression note</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%external ccall "</code> { char } <code>"</code> aty</entry> + <entry>external reference</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%dynexternal ccall</code> aty</entry> + <entry>external reference (dynamic)</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>%label "</code> { char } <code>"</code></entry> + <entry>external label</entry> + </row> + + <row> + <entry morerows="1" valign="top">Argument</entry> + <entry morerows="1" valign="top">arg</entry> + <entry>→</entry> + <entry><code>@</code> aty</entry> + <entry>type argument</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry>aexp</entry> + <entry>value argument</entry> + </row> + + <row> + <entry morerows="2" valign="top">Case alt.</entry> + <entry morerows="2" valign="top">alt</entry> + <entry>→</entry> + <entry>qdcon { <code>@</code> tbind }{ vbind } <code>&arw;</code> exp</entry> + <entry>constructor alternative</entry> + </row> + + <row> + <entry>∣</entry> + <entry>lit <code>&arw;</code> exp</entry> + <entry>literal alternative</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>%_ &arw;</code> exp</entry> + <entry>default alternative</entry> + </row> + + <row> + <entry morerows="1" valign="top">Binder</entry> + <entry morerows="1" valign="top">binder</entry> + <entry>→</entry> + <entry><code>@</code> tbind</entry> + <entry>type binder</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry>vbind</entry> + <entry>value binder</entry> + </row> + + <row> + <entry morerows="1" valign="top">Type binder</entry> + <entry morerows="1" valign="top">tbind</entry> + <entry>→</entry> + <entry>tyvar</entry> + <entry>implicitly of kind *</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>(</code> tyvar <code>::</code> kind <code>)</code></entry> + <entry>explicitly kinded</entry> + </row> + + <row rowsep="1"> + <entry>Value binder</entry> + <entry>vbind</entry> + <entry>→</entry> + <entry><code>(</code> var <code>::</code> ty <code>)</code></entry> + <entry></entry> + </row> + + <row> + <entry morerows="3" valign="top">Literal</entry> + <entry morerows="3" valign="top">lit</entry> + <entry>→</entry> + <entry><code>(</code> [<code>-</code>] { digit }<superscript>+</superscript> <code>::</code> ty <code>)</code></entry> + <entry>integer</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>(</code> [<code>-</code>] { digit }<superscript>+</superscript> <code>%</code> { digit }<superscript>+</superscript> <code>::</code> ty <code>)</code></entry> + <entry>rational</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>( '</code> char <code>' ::</code> ty <code>)</code></entry> + <entry>character</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>( "</code> { char } <code>" ::</code> ty <code>)</code></entry> + <entry>string</entry> + </row> + + <row> + <entry morerows="2" valign="top">Character</entry> + <entry morerows="1" valign="top">char</entry> + <entry>→</entry> + <entry namest="rhs" nameend="name"><emphasis>any ASCII character in range 0x20-0x7E except 0x22,0x27,0x5c</emphasis></entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>\x</code> hex hex</entry> + <entry>ASCII code escape sequence</entry> + </row> + + <row rowsep="1"> + <entry>hex</entry> + <entry>→</entry> + <entry>0∣…∣9 ∣a ∣…∣f</entry> + <entry></entry> + </row> + + <row> + <entry morerows="2" valign="top">Atomic type</entry> + <entry morerows="2" valign="top">aty</entry> + <entry>→</entry> + <entry>tyvar</entry> + <entry>type variable</entry> + </row> + + <row> + <entry>∣</entry> + <entry>qtycon</entry> + <entry>type constructor</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>(</code> ty <code>)</code></entry> + <entry>nested type</entry> + </row> + + <row> + <entry morerows="7" valign="top">Basic type</entry> + <entry morerows="7" valign="top">bty</entry> + <entry>→</entry> + <entry>aty</entry> + <entry>atomic type</entry> + </row> + + <row> + <entry>∣</entry> + <entry>bty aty</entry> + <entry>type application</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%trans</code> aty aty</entry> + <entry>transitive coercion</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%sym</code> aty</entry> + <entry>symmetric coercion</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%unsafe</code> aty aty</entry> + <entry>unsafe coercion</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%left</code> aty</entry> + <entry>left coercion</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%right</code> aty</entry> + <entry>right coercion</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>%inst</code> aty aty</entry> + <entry>instantiation coercion</entry> + </row> + + <row> + <entry morerows="2" valign="top">Type</entry> + <entry morerows="2" valign="top">ty</entry> + <entry>→</entry> + <entry>bty</entry> + <entry>basic type</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>%forall</code> { tbind }<superscript>+</superscript> <code>.</code> ty</entry> + <entry>type abstraction</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry>bty <code>&arw;</code> ty</entry> + <entry>arrow type construction</entry> + </row> + + <row> + <entry morerows="4" valign="top">Atomic kind</entry> + <entry morerows="4" valign="top">akind</entry> + <entry>→</entry> + <entry><code>*</code></entry> + <entry>lifted kind</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>#</code></entry> + <entry>unlifted kind</entry> + </row> + + <row> + <entry>∣</entry> + <entry><code>?</code></entry> + <entry>open kind</entry> + </row> + + <row> + <entry>∣</entry> + <entry>bty <code>:=:</code> bty</entry> + <entry>equality kind</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry><code>(</code> kind <code>)</code></entry> + <entry>nested kind</entry> + </row> + + <row> + <entry morerows="1" valign="top">Kind</entry> + <entry morerows="1" valign="top">kind</entry> + <entry>→</entry> + <entry>akind</entry> + <entry>atomic kind</entry> + </row> + + <row rowsep="1"> + <entry>∣</entry> + <entry>akind <code>&arw;</code> kind</entry> + <entry>arrow kind</entry> + </row> + + <row> + <entry morerows="7" valign="top">Identifier</entry> + <entry>mident</entry> + <entry>→</entry> + <entry>pname <code>:</code> uname</entry> + <entry>module</entry> + </row> + + <row> + <entry>tycon</entry> + <entry>→</entry> + <entry>uname</entry> + <entry>type constr.</entry> + </row> + + <row> + <entry>qtycon</entry> + <entry>→</entry> + <entry>mident <code>.</code> tycon</entry> + <entry>qualified type constr.</entry> + </row> + + <row> + <entry>tyvar</entry> + <entry>→</entry> + <entry>lname</entry> + <entry>type variable</entry> + </row> + + <row> + <entry>dcon</entry> + <entry>→</entry> + <entry>uname</entry> + <entry>data constr.</entry> + </row> + + <row> + <entry>qdcon</entry> + <entry>→</entry> + <entry>mident <code>.</code> dcon</entry> + <entry>qualified data constr.</entry> + </row> + + <row> + <entry>var</entry> + <entry>→</entry> + <entry>lname</entry> + <entry>variable</entry> + </row> + + <row rowsep="1"> + <entry>qvar</entry> + <entry>→</entry> + <entry>[ mident <code>.</code> ] var</entry> + <entry>optionally qualified variable</entry> + </row> + + <row> + <entry morerows="6" valign="top">Name</entry> + <entry>lname</entry> + <entry>→</entry> + <entry>lower { namechar }</entry> + <entry></entry> + </row> + + <row> + <entry>uname</entry> + <entry>→</entry> + <entry>upper { namechar }</entry> + <entry></entry> + </row> + + <row> + <entry>pname</entry> + <entry>→</entry> + <entry>{ namechar }<superscript>+</superscript></entry> + <entry></entry> + </row> + + <row> + <entry>namechar</entry> + <entry>→</entry> + <entry>lower ∣ upper ∣ digit</entry> + <entry></entry> + </row> + + <row> + <entry>lower</entry> + <entry>→</entry> + <entry><code>a</code> ∣ <code>b</code> ∣ … ∣ <code>z</code> ∣ <code>_</code></entry> + <entry></entry> + </row> + + <row> + <entry>upper</entry> + <entry>→</entry> + <entry><code>A</code> ∣ <code>B</code> ∣ … ∣ <code>Z</code></entry> + <entry></entry> + </row> + + <row> + <entry>digit</entry> + <entry>→</entry> + <entry><code>0</code> ∣ <code>1</code> ∣ … ∣ <code>9</code></entry> + <entry></entry> + </row> + </tbody> + </tgroup> + </informaltable> + </section> + + <section id="informal-semantics"> + <title>Informal Semantics</title> + + <para>At the term level, Core resembles a explicitly-typed polymorphic + lambda calculus (F<subscript>ω</subscript>), with the addition of + local <code>let</code> bindings, algebraic type definitions, constructors, and + <code>case</code> expressions, and primitive types, literals and operators. Its + type system is richer than that of System F, supporting explicit + type equality coercions and type functions.<citation>system-fc</citation></para> + + <para>In this section we concentrate on the less obvious points about + Core.</para> + + <section id="program-organization-and-modules"> + <title>Program Organization and Modules</title> + + <para>Core programs are organized into <emphasis>modules</emphasis>, corresponding directly + to source-level Haskell modules. Each module has a identifying + name <emphasis>mident</emphasis>. A module identifier consists of a <emphasis>package name</emphasis> + followed by a module name, which may be hierarchical: for + example, <code>base:GHC.Base</code> is the module identifier for GHC’s Base + module. Its name is <code>Base</code>, and it lives in the GHC hierarchy + within the <code>base</code> package. Section 5.8 of the GHC users’ guide + explains package names <citation>ghc-user-guide</citation>. In particular, note that a Core + program may contain multiple modules with the same (possibly + hierarchical) module name that differ in their package names. In + some of the code examples that follow, we will omit package + names and possibly full hierarchical module names from + identifiers for brevity, but be aware that they are always + required.<footnote> + A possible improvement to the Core syntax + would be to add explicit import lists to Core modules, which could be + used to specify abbrevations for long qualified names. This would make + the code more human-readable. + </footnote></para> + + <para>Each module may contain the following kinds of top-level + declarations: + + <itemizedlist> + <listitem> + Algebraic data type declarations, each defining a type + constructor and one or more data constructors; + </listitem> + <listitem> + Newtype declarations, corresponding to Haskell <code>newtype</code> + declarations, each defining a type constructor and a + coercion name; and + </listitem> + <listitem> + Value declarations, defining the types and values of + top-level variables. + </listitem> + </itemizedlist> + </para> + + <para>No type constructor, data constructor, or top-level value may be + declared more than once within a given module. All the type + declarations are (potentially) mutually recursive. Value + declarations must be in dependency order, with explicit grouping + of potentially mutually recursive declarations.</para> + + <para>Identifiers defined in top-level declarations may be <emphasis>external</emphasis> or + <emphasis>internal</emphasis>. External identifiers can be referenced from any other + module in the program, using conventional dot notation (e.g., + <code>base:GHC.Base.Bool</code>, <code>base:GHC.Base.True</code>). Internal identifiers + are visible only within the defining module. All type and data + constructors are external, and are always defined and referenced + using fully qualified names (with dots).</para> + + <para>A top-level value is external if it is defined and referenced + using a fully qualified name with a dot (e.g., <code>main:MyModule.foo = ...</code>); + otherwise, it is internal (e.g., <code>bar = ...</code>). Note that + Core’s notion of an external identifier does not necessarily + coincide with that of <quote>exported</quote> identifier in a Haskell source + module. An identifier can be an external identifier in Core, but + not be exported by the original Haskell source + module.<footnote> + Two examples of such identifiers are: data + constructors, and values that potentially appear in an unfolding. For an + example of the latter, consider <code>Main.foo = ... Main.bar ...</code>, where + <code>Main.foo</code> is inlineable. Since <code>bar</code> appears in <code>foo</code>’s unfolding, it is + defined and referenced with an external name, even if <code>bar</code> was not + exported by the original source module. + </footnote> + However, if an identifier was exported by the Haskell source + module, it will appear as an external name in Core.</para> + + <para>Core modules have no explicit import or export lists. Modules + may be mutually recursive. Note that because of the latter fact, + GHC currently prints out the top-level bindings for every module + as a single recursive group, in order to avoid keeping track of + dependencies between top-level values within a module. An + external Core tool could reconstruct dependencies later, of + course.</para> + + <para>There is also an implicitly-defined module <code>ghc-prim:GHC.Prim</code>, + which exports the <quote>built-in</quote> types and values that must be + provided by any implementation of Core (including GHC). Details + of this module are in the <link linkend="primitive-module">Primitive Module section</link>.</para> + + <para>A Core <emphasis>program</emphasis> is a collection of distinctly-named modules that + includes a module called main:Main having an exported value + called <code>main:ZCMain.main</code> of type <code>base:GHC.IOBase.IO a</code> (for some + type <code>a</code>). (Note that the strangely named wrapper for <code>main</code> is the + one exception to the rule that qualified names defined within a + module <code>m</code> must have module name <code>m</code>.)</para> + + <para>Many Core programs will contain library modules, such as + <code>base:GHC.Base</code>, which implement parts of the Haskell standard + library. In principle, these modules are ordinary Haskell + modules, with no special status. In practice, the requirement on + the type of <code>main:Main.main</code> implies that every program will + contain a large subset of the standard library modules.</para> + + </section> + <section id="namespaces"> + <title>Namespaces</title> + + <para>There are five distinct namespaces: + <orderedlist> + <listitem>module identifiers (<code>mident</code>),</listitem> + <listitem>type constructors (<code>tycon</code>),</listitem> + <listitem>type variables (<code>tyvar</code>),</listitem> + <listitem>data constructors (<code>dcon</code>),</listitem> + <listitem>term variables (<code>var</code>).</listitem> + </orderedlist> + </para> + + <para>Spaces (1), (2+3), and (4+5) can be distinguished from each + other by context. To distinguish (2) from (3) and (4) from (5), + we require that data and type constructors begin with an + upper-case character, and that term and type variables begin + with a lower-case character.</para> + + <para>Primitive types and operators are not syntactically + distinguished.</para> + + <para>Primitive <emphasis>coercion</emphasis> operators, of which there are six, <emphasis>are</emphasis> + syntactically distinguished in the grammar. This is because + these coercions must be fully applied, and because + distinguishing their applications in the syntax makes + typechecking easier.</para> + + <para>A given variable (type or term) may have multiple definitions + within a module. However, definitions of term variables never + <quote>shadow</quote> one another: the scope of the definition of a given + variable never contains a redefinition of the same variable. + Type variables may be shadowed. Thus, if a term variable has + multiple definitions within a module, all those definitions must + be local (let-bound). The only exception to this rule is that + (necessarily closed) types labelling <code>%external</code> expressions may + contain <code>tyvar</code> bindings that shadow outer bindings.</para> + + <para>Core generated by GHC makes heavy use of encoded names, in which + the characters <code>Z</code> and <code>z</code> are used to introduce escape sequences + for non-alphabetic characters such as dollar sign <code>$</code> (<code>zd</code>), hash <code>#</code> + (<code>zh</code>), plus <code>+</code> (<code>zp</code>), etc. This is the same encoding used in <code>.hi</code> + files and in the back-end of GHC itself, except that we + sometimes change an initial <code>z</code> to <code>Z</code>, or vice-versa, in order to + maintain case distinctions.</para> + + <para>Finally, note that hierarchical module names are z-encoded in + Core: for example, <code>base:GHC.Base.foo</code> is rendered as + <code>base:GHCziBase.foo</code>. A parser may reconstruct the module + hierarchy, or regard <code>GHCziBase</code> as a flat name.</para> + + </section> + <section id="types-and-kinds"> + <title>Types and Kinds</title> + + <para>In Core, all type abstractions and applications are explicit. + This make it easy to typecheck any (closed) fragment of Core + code. An full executable typechecker is available separately.</para> + + <section id="types"> + <title>Types</title> + + <para>Types are described by type expressions, which are built from + named type constructors and type variables using type + application and universal quantification. Each type + constructor has a fixed arity ≥ 0. Because it is so widely + used, there is special infix syntax for the fully-applied + function type constructor (<code>&arw;</code>). (The prefix identifier for + this constructor is <code>ghc-prim:GHC.Prim.ZLzmzgZR</code>; this should + only appear in unapplied or partially applied form.)</para> + + <para>There are also a number of other primitive type constructors + (e.g., <code>Intzh</code>) that are predefined in the <code>GHC.Prim</code> module, but + have no special syntax. <code>%data</code> and <code>%newtype</code> declarations + introduce additional type constructors, as described below. + Type constructors are distinguished solely by name.</para> + + </section> + <section id="coercions"> + <title>Coercions</title> + + <para>A type may also be built using one of the primitive coercion + operators, as described in <link linkend="namespaces">the Namespaces section</link>. For details on the + meanings of these operators, see the System FC paper <citation>system-fc</citation>. Also + see <link linkend="newtypes">the Newtypes section</link> for + examples of how GHC uses coercions in Core code.</para> + + </section> + <section id="kinds"> + <title>Kinds</title> + <para>As described in the Haskell definition, it is necessary to + distinguish well-formed type-expressions by classifying them + into different <emphasis>kinds</emphasis> <citation>haskell98, p. 41</citation><!-- TODO -->. In particular, Core + explicitly records the kind of every bound type variable.</para> + + <para>In addition, Core’s kind system includes equality kinds, as in + System FC <citation>system-fc</citation>. An application of a built-in coercion, or of a + user-defined coercion as introduced by a <code>newtype</code> declaration, + has an equality kind.</para> + + </section> + <section id="lifted-and-unlifted-types"> + <title>Lifted and Unlifted Types</title> + + <para>Semantically, a type is <emphasis>lifted</emphasis> if and only if it has bottom as + an element. We need to distinguish them because operationally, + terms with lifted types may be represented by closures; terms + with unlifted types must not be represented by closures, which + implies that any unboxed value is necessarily unlifted. We + distinguish between lifted and unlifted types by ascribing + them different kinds.</para> + + <para>Currently, all the primitive types are unlifted (including a + few boxed primitive types such as <code>ByteArrayzh</code>). Peyton-Jones + and Launchbury <citation>pj:unboxed</citation> described the ideas behind unboxed and + unlifted types.</para> + + </section> + <section id="type-constructors-base-kinds-and-higher-kinds"> + <title>Type Constructors; Base Kinds and Higher Kinds</title> + + <para>Every type constructor has a kind, depending on its arity and + whether it or its arguments are lifted.</para> + + <para>Term variables can only be assigned types that have base + kinds: the base kinds are <code>*</code>, <code>#</code>, and <code>?</code>. The three base kinds + distinguish the liftedness of the types they classify: <code>*</code> + represents lifted types; <code>#</code> represents unlifted types; and <code>?</code> is + the <quote>open</quote> kind, representing a type that may be either lifted + or unlifted. Of these, only <code>*</code> ever appears in Core type + declarations generated from user code; the other two are + needed to describe certain types in primitive (or otherwise + specially-generated) code (which, after optimization, could + potentially appear anywhere).</para> + + <para>In particular, no top-level identifier (except in + <code>ghc-prim:GHC.Prim</code>) has a type of kind <code>#</code> or <code>?</code>.</para> + + <para>Nullary type constructors have base kinds: for example, the + type <code>Int</code> has kind <code>*</code>, and <code>Int#</code> has kind <code>#</code>.</para> + + <para>Non-nullary type constructors have higher kinds: kinds that + have the form + k<subscript>1</subscript><code>&arw;</code>k<subscript>2</subscript>, where + k<subscript>1</subscript> and k<subscript>2</subscript> are + kinds. For example, the function type constructor <code>&arw;</code> has + kind <code>* &arw; (* &arw; *)</code>. Since Haskell allows abstracting + over type constructors, type variables may have higher kinds; + however, much more commonly they have kind <code>*</code>, so that is the + default if a type binder omits a kind.</para> + + </section> + + <section id="type-synonyms-and-type-equivalence"> + <title>Type Synonyms and Type Equivalence</title> + + <para>There is no mechanism for defining type synonyms + (corresponding to Haskell <code>type</code> declarations).</para> + + <para>Type equivalence is just syntactic equivalence on type + expressions (of base kinds) modulo:</para> + + <itemizedlist> + <listitem>alpha-renaming of variables bound in <code>%forall</code> types;</listitem> + <listitem>the identity a <code>&arw;</code> b ≡ <code>ghc-prim:GHC.Prim.ZLzmzgZR</code> a b</listitem> + </itemizedlist> + + </section> + </section> + <section id="algebraic-data-types"> + <title>Algebraic data types</title> + + <para>Each data declaration introduces a new type constructor and a + set of one or more data constructors, normally corresponding + directly to a source Haskell <code>data</code> declaration. For example, the + source declaration + + <programlisting language="haskell"> +data Bintree a = + Fork (Bintree a) (Bintree a) + | Leaf a + </programlisting> + + might induce the following Core declaration + + <programlisting language="java"> +%data Bintree a = { + Fork (Bintree a) (Bintree a); + Leaf a)} + </programlisting> + + which introduces the unary type constructor Bintree of kind + <code>*&arw;*</code> and two data constructors with types + + <programlisting language="java"> +Fork :: %forall a . Bintree a &arw; Bintree a &arw; Bintree a +Leaf :: %forall a . a &arw; Bintree a + </programlisting> + + We define the <emphasis>arity</emphasis> of each data constructor to be the number of + value arguments it takes; e.g. <code>Fork</code> has arity 2 and <code>Leaf</code> has + arity 1.</para> + + <para>For a less conventional example illustrating the possibility of + higher-order kinds, the Haskell source declaration + + <programlisting language="haskell"> +data A f a = MkA (f a) + </programlisting> + + might induce the Core declaration + + <programlisting language="java"> +%data A (f::*&arw;*) a = { MkA (f a) } + </programlisting> + + which introduces the constructor + + <programlisting language="java"> +MkA :: %forall (f::*&arw;*) a . (f a) &arw; (A f) a + </programlisting></para> + + <para>GHC (like some other Haskell implementations) supports an + extension to Haskell98 for existential types such as + + <programlisting language="haskell"> +data T = forall a . MkT a (a &arw; Bool) + </programlisting> + + This is represented by the Core declaration + + <programlisting language="java"> +%data T = {MkT @a a (a &arw; Bool)} + </programlisting> + + which introduces the nullary type constructor T and the data + constructor + + <programlisting language="java"> +MkT :: %forall a . a &arw; (a &arw; Bool) &arw; T + </programlisting> + + In general, existentially quantified variables appear as extra + universally quantified variables in the data contructor types. An + example of how to construct and deconstruct values of type <code>T</code> is + shown in <link linkend="expression-forms">the Expression Forms section</link>.</para> + + </section> + <section id="newtypes"> + <title>Newtypes</title> + + <para>Each Core <code>%newtype</code> declaration introduces a new type constructor + and an associated representation type, corresponding to a source + Haskell <code>newtype</code> declaration. However, unlike in source Haskell, + a <code>%newtype</code> declaration does not introduce any data constructors.</para> + + <para>Each <code>%newtype</code> declaration also introduces a new coercion + (syntactically, just another type constructor) that implies an + axiom equating the type constructor, applied to any type + variables bound by the <code>%newtype</code>, to the representation type.</para> + + <para>For example, the Haskell fragment + + <programlisting language="haskell"> +newtype U = MkU Bool +u = MkU True +v = case u of + MkU b &arw; not b + </programlisting> + + might induce the Core fragment + + <programlisting language="java"> +%newtype U ZCCoU = Bool; +u :: U = %cast (True) + ((%sym ZCCoU)); +v :: Bool = not (%cast (u) ZCCoU); + </programlisting></para> + + <para>The <code>newtype</code> declaration implies that the types <code>U</code> and <code>Bool</code> have + equivalent representations, and the coercion axiom <code>ZCCoU</code> + provides evidence that <code>U</code> is equivalent to <code>Bool</code>. Notice that in + the body of <code>u</code>, the boolean value <code>True</code> is cast to type <code>U</code> using + the primitive symmetry rule applied to <code>ZCCoU</code>: that is, using a + coercion of kind <code>Bool :=: U</code>. And in the body of <code>v</code>, <code>u</code> is cast + back to type <code>Bool</code> using the axiom <code>ZCCoU</code>.</para> + + <para>Notice that the <code>case</code> in the Haskell source code above translates + to a <code>cast</code> in the corresponding Core code. That is because + operationally, a <code>case</code> on a value whose type is declared by a + <code>newtype</code> declaration is a no-op. Unlike a <code>case</code> on any other + value, such a <code>case</code> does no evaluation: its only function is to + coerce its scrutinee’s type.</para> + + <para>Also notice that unlike in a previous draft version of External + Core, there is no need to handle recursive newtypes specially.</para> + + </section> + + <section id="expression-forms"> + <title>Expression Forms</title> + + <para>Variables and data constructors are straightforward.</para> + + <para>Literal (<emphasis role="variable">lit</emphasis>) expressions consist of a literal value, in one of + four different formats, and a (primitive) type annotation. Only + certain combinations of format and type are permitted; + see <link linkend="primitive-module">the Primitive Module section</link>. + The character and string formats can describe only 8-bit ASCII characters.</para> + + <para>Moreover, because the operational semantics for Core interprets + strings as C-style null-terminated strings, strings should not + contain embedded nulls.</para> + + <para>In Core, value applications, type applications, value + abstractions, and type abstractions are all explicit. To tell + them apart, type arguments in applications and formal type + arguments in abstractions are preceded by an <code>@ symbol</code>. (In + abstractions, the <code>@</code> plays essentially the same role as the more + usual Λ symbol.) For example, the Haskell source declaration + + <programlisting language="haskell"> +f x = Leaf (Leaf x) + </programlisting> + + might induce the Core declaration + + <programlisting language="java"> +f :: %forall a . a &arw; BinTree (BinTree a) = + \ @a (x::a) &arw; Leaf @(Bintree a) (Leaf @a x) + </programlisting></para> + + <para>Value applications may be of user-defined functions, data + constructors, or primitives. None of these sorts of applications + are necessarily saturated.</para> + + <para>Note that the arguments of type applications are not always of + kind <code>*</code>. For example, given our previous definition of type <code>A</code>: + + <programlisting language="haskell"> +data A f a = MkA (f a) + </programlisting> + + the source code + + <programlisting language="haskell"> +MkA (Leaf True) + </programlisting> + + becomes + + <programlisting language="java"> +(MkA @Bintree @Bool) (Leaf @Bool True) + </programlisting></para> + + <para>Local bindings, of a single variable or of a set of mutually + recursive variables, are represented by <code>%let</code> expressions in the + usual way.</para> + + <para>By far the most complicated expression form is <code>%case</code>. <code>%case</code> + expressions are permitted over values of any type, although they + will normally be algebraic or primitive types (with literal + values). Evaluating a <code>%case</code> forces the evaluation of the + expression being tested (the <quote>scrutinee</quote>). The value of the + scrutinee is bound to the variable following the <code>%of</code> keyword, + which is in scope in all alternatives; this is useful when the + scrutinee is a non-atomic expression (see next example). The + scrutinee is preceded by the type of the entire <code>%case</code> + expression: that is, the result type that all of the <code>%case</code> + alternatives have (this is intended to make type reconstruction + easier in the presence of type equality coercions).</para> + + <para>In an algebraic <code>%case</code>, all the case alternatives must be labeled + with distinct data constructors from the algebraic type, + followed by any existential type variable bindings (see below), + and typed term variable bindings corresponding to the data + constructor’s arguments. The number of variables must match the + data constructor’s arity.</para> + + <para>For example, the following Haskell source expression + + <programlisting language="haskell"> +case g x of + Fork l r &arw; Fork r l + t@(Leaf v) &arw; Fork t t + </programlisting> + + might induce the Core expression + + <programlisting language="java"> +%case ((Bintree a)) g x %of (t::Bintree a) + Fork (l::Bintree a) (r::Bintree a) &arw; + Fork @a r l + Leaf (v::a) &arw; + Fork @a t t + </programlisting></para> + + <para>When performing a <code>%case</code> over a value of an + existentially-quantified algebraic type, the alternative must + include extra local type bindings for the + existentially-quantified variables. For example, given + + <programlisting language="haskell"> +data T = forall a . MkT a (a &arw; Bool) + </programlisting> + + the source + + <programlisting language="haskell"> +case x of + MkT w g &arw; g w + </programlisting> + + becomes + + <programlisting language="java"> +%case x %of (x’::T) + MkT @b (w::b) (g::b&arw;Bool) &arw; g w + </programlisting></para> + + <para>In a <code>%case</code> over literal alternatives, all the case alternatives + must be distinct literals of the same primitive type.</para> + + <para>The list of alternatives may begin with a default alternative + labeled with an underscore (<code>%_</code>), whose right-hand side will be + evaluated if none of the other alternatives match. The default + is optional except for in a case over a primitive type, or when + there are no other alternatives. If the case is over neither an + algebraic type nor a primitive type, then the list of + alternatives must contain a default alternative and nothing + else. For algebraic cases, the set of alternatives need not be + exhaustive, even if no default is given; if alternatives are + missing, this implies that GHC has deduced that they cannot + occur.</para> + + <para><code>%cast</code> is used to manipulate newtypes, as described in + <link linkend="newtypes">the Newtype section</link>. The <code>%cast</code> expression + takes an expression and a coercion: syntactically, the coercion + is an arbitrary type, but it must have an equality kind. In an + expression <code>(cast e co)</code>, if <code>e :: T</code> and <code>co</code> has kind <code>T :=: U</code>, then + the overall expression has type <code>U</code> <citation>ghc-fc-commentary</citation>. Here, <code>co</code> must be a + coercion whose left-hand side is <code>T</code>.</para> + + <para>Note that unlike the <code>%coerce</code> expression that existed in previous + versions of Core, this means that <code>%cast</code> is (almost) type-safe: + the coercion argument provides evidence that can be verified by + a typechecker. There are still unsafe <code>%cast</code>s, corresponding to + the unsafe <code>%coerce</code> construct that existed in old versions of + Core, because there is a primitive unsafe coercion type that can + be used to cast arbitrary types to each other. GHC uses this for + such purposes as coercing the return type of a function (such as + error) which is guaranteed to never return: + + <programlisting language="haskell"> +case (error "") of + True &arw; 1 + False &arw; 2 + </programlisting> + + becomes: + + <programlisting language="java"> +%cast (error @ Bool (ZMZN @ Char)) +(%unsafe Bool Integer); + </programlisting> + + <code>%cast</code> has no operational meaning and is only used in + typechecking.</para> + + <para>A <code>%note</code> expression carries arbitrary internal information that + GHC finds interesting. The information is encoded as a string. + Expression notes currently generated by GHC include the inlining + pragma (<code>InlineMe</code>) and cost-center labels for profiling.</para> + + <para>A <code>%external</code> expression denotes an external identifier, which has + the indicated type (always expressed in terms of Haskell + primitive types). External Core supports two kinds of external + calls: <code>%external</code> and <code>%dynexternal</code>. Only the former is supported + by the current set of stand-alone Core tools. In addition, there + is a <code>%label</code> construct which GHC may generate but which the Core + tools do not support.</para> + + <para>The present syntax for externals is sufficient for describing C + functions and labels. Interfacing to other languages may require + additional information or a different interpretation of the name + string.</para> + + </section> + + <section id="expression-evaluation"> + <title>Expression Evaluation</title> + <para>The dynamic semantics of Core are defined on the type-erasure of + the program: for example, we ignore all type abstractions and + applications. The denotational semantics of the resulting + type-free program are just the conventional ones for a + call-by-name language, in which expressions are only evaluated + on demand. But Core is intended to be a call-by-<emphasis>need</emphasis> language, + in which expressions are only evaluated once. To express the + sharing behavior of call-by-need, we give an operational model + in the style of Launchbury <citation>launchbury93natural</citation>.</para> + + <para>This section describes the model informally; a more formal + semantics is separately available as an executable interpreter.</para> + + <para>To simplify the semantics, we consider only <quote>well-behaved</quote> Core + programs in which constructor and primitive applications are + fully saturated, and in which non-trivial expresssions of + unlifted kind (<code>#</code>) appear only as scrutinees in <code>%case</code> + expressions. Any program can easily be put into this form; a + separately available preprocessor illustrates how. In the + remainder of this section, we use <quote>Core</quote> to mean <quote>well-behaved</quote> + Core.</para> + + <para>Evaluating a Core expression means reducing it to <emphasis>weak-head normal form (WHNF)</emphasis>, + i.e., a primitive value, lambda abstraction, + or fully-applied data constructor. Evaluating a program means + evaluating the expression <code>main:ZCMain.main</code>.</para> + + <para>To make sure that expression evaluation is shared, we make use + of a <emphasis>heap</emphasis>, which contains <emphasis>heap entries</emphasis>. A heap entry can be: + + <itemizedlist> + <listitem> + A <emphasis>thunk</emphasis>, representing an unevaluated expression, also known + as a suspension. + </listitem> + <listitem> + A <emphasis>WHNF</emphasis>, representing an evaluated expression. The result of + evaluating a thunk is a WHNF. A WHNF is always a closure + (corresponding to a lambda abstraction in the source + program) or a data constructor application: computations + over primitive types are never suspended. + </listitem> + </itemizedlist></para> + + <para><emphasis>Heap pointers</emphasis> point to heap entries: at different times, the + same heap pointer can point to either a thunk or a WHNF, because + the run-time system overwrites thunks with WHNFs as computation + proceeds.</para> + + <para>The suspended computation that a thunk represents might + represent evaluating one of three different kinds of expression. + The run-time system allocates a different kind of thunk + depending on what kind of expression it is: + + <itemizedlist> + <listitem> + A thunk for a value definition has a group of suspended + defining expressions, along with a list of bindings between + defined names and heap pointers to those suspensions. (A + value definition may be a recursive group of definitions or + a single non-recursive definition, and it may be top-level + (global) or <code>let</code>-bound (local)). + </listitem> + <listitem> + A thunk for a function application (where the function is + user-defined) has a suspended actual argument expression, + and a binding between the formal argument and a heap pointer + to that suspension. + </listitem> + <listitem> + A thunk for a constructor application has a suspended actual + argument expression; the entire constructed value has a heap + pointer to that suspension embedded in it. + </listitem> + </itemizedlist></para> + + <para>As computation proceeds, copies of the heap pointer for a given + thunk propagate through the executing program. When another + computation demands the result of that thunk, the thunk is + <emphasis>forced</emphasis>: the run-time system computes the thunk’s result, + yielding a WHNF, and overwrites the heap entry for the thunk + with the WHNF. Now, all copies of the heap pointer point to the + new heap entry: a WHNF. Forcing occurs only in the context of + + <itemizedlist> + <listitem>evaluating the operator expression of an application;</listitem> + <listitem>evaluating the scrutinee of a <code>case</code> expression; or</listitem> + <listitem>evaluating an argument to a primitive or external function application</listitem> + </itemizedlist> + </para> + + <para>When no pointers to a heap entry (whether it is a thunk or WHNF) + remain, the garbage collector can reclaim the space it uses. We + assume this happens implicitly.</para> + + <para>With the exception of functions, arrays, and mutable variables, + we intend that values of all primitive types should be held + <emphasis>unboxed</emphasis>: they should not be heap-allocated. This does not + violate call-by-need semantics: all primitive types are + <emphasis>unlifted</emphasis>, which means that values of those types must be + evaluated strictly. Unboxed tuple types are not heap-allocated + either.</para> + + <para>Certain primitives and <code>%external</code> functions cause side-effects to + state threads or to the real world. Where the ordering of these + side-effects matters, Core already forces this order with data + dependencies on the pseudo-values representing the threads.</para> + + <para>An implementation must specially support the <code>raisezh</code> and + <code>handlezh</code> primitives: for example, by using a handler stack. + Again, real-world threading guarantees that they will execute in + the correct order.</para> + + </section> + </section> + <section id="primitive-module"> + <title>Primitive Module</title> + + <para>The semantics of External Core rely on the contents and informal + semantics of the primitive module <code>ghc-prim:GHC.Prim</code>. Nearly all + the primitives are required in order to cover GHC’s implementation + of the Haskell98 standard prelude; the only operators that can be + completely omitted are those supporting the byte-code interpreter, + parallelism, and foreign objects. Some of the concurrency + primitives are needed, but can be given degenerate implementations + if it desired to target a purely sequential backend (see Section + <link linkend="non-concurrent-back-end">the Non-concurrent Back End section</link>).</para> + + <para>In addition to these primitives, a large number of C library + functions are required to implement the full standard Prelude, + particularly to handle I/O and arithmetic on less usual types.</para> + + <para>For a full listing of the names and types of the primitive + operators, see the GHC library documentation <citation>ghcprim</citation>.</para> + + <section id="non-concurrent-back-end"> + <title>Non-concurrent Back End</title> + + <para>The Haskell98 standard prelude doesn’t include any concurrency + support, but GHC’s implementation of it relies on the existence + of some concurrency primitives. However, it never actually forks + multiple threads. Hence, the concurrency primitives can be given + degenerate implementations that will work in a non-concurrent + setting, as follows:</para> + + <itemizedlist> + <listitem> + <code>ThreadIdzh</code> can be represented by a singleton type, whose + (unique) value is returned by <code>myThreadIdzh</code>. + </listitem> + <listitem> + <code>forkzh</code> can just die with an <quote>unimplemented</quote> message. + </listitem> + <listitem> + <code>killThreadzh</code> and <code>yieldzh</code> can also just die <quote>unimplemented</quote> + since in a one-thread world, the only thread a thread can + kill is itself, and if a thread yields the program hangs. + </listitem> + <listitem> + <code>MVarzh a</code> can be represented by <code>MutVarzh (Maybe a)</code>; where a + concurrent implementation would block, the sequential + implementation can just die with a suitable message (since + no other thread exists to unblock it). + </listitem> + <listitem> + <code>waitReadzh</code> and <code>waitWritezh</code> can be implemented using a <code>select</code> + with no timeout. + </listitem> + </itemizedlist> + </section> + + <section id="literals"> + <title>Literals</title> + + <para>Only the following combination of literal forms and types are + permitted:</para> + + <informaltable frame="none" colsep="0" rowsep="0"> + <tgroup cols='3'> + <colspec colname="literal" align="left" colwidth="*" /> + <colspec colname="type" align="left" colwidth="*" /> + <colspec colname="description" align="left" colwidth="4*" /> + <thead> + <row> + <entry>Literal form</entry> + <entry>Type</entry> + <entry>Description</entry> + </row> + </thead> + <tbody> + <row> + <entry morerows="3" valign="top">integer</entry> + <entry><code>Intzh</code></entry> + <entry>Int</entry> + </row> + <row> + <entry><code>Wordzh</code></entry> + <entry>Word</entry> + </row> + <row> + <entry><code>Addrzh</code></entry> + <entry>Address</entry> + </row> + <row> + <entry><code>Charzh</code></entry> + <entry>Unicode character code</entry> + </row> + + <row> + <entry morerows="1" valign="top">rational</entry> + <entry><code>Floatzh</code></entry> + <entry>Float</entry> + </row> + <row> + <entry><code>Doublezh</code></entry> + <entry>Double</entry> + </row> + + <row> + <entry>character</entry> + <entry><code>Charzh</code></entry> + <entry>Unicode character specified by ASCII character</entry> + </row> + + <row> + <entry>string</entry> + <entry><code>Addrzh</code></entry> + <entry>Address of specified C-format string</entry> + </row> + </tbody> + </tgroup> + </informaltable> + </section> + </section> + + + <bibliolist> + <!-- This bibliography was semi-automatically converted by JabRef from core.bib. --> + + <title>References</title> + + <biblioentry> + <abbrev>ghc-user-guide</abbrev> + <authorgroup> + <author><surname>The GHC Team</surname></author> + </authorgroup> + <citetitle pubwork="article">The Glorious Glasgow Haskell Compilation System User's Guide, Version 6.8.2</citetitle> + <pubdate>2008</pubdate> + <bibliomisc><ulink url="http://www.haskell.org/ghc/docs/latest/html/users_guide/index.html">http://www.haskell.org/ghc/docs/latest/html/users_guide/index.html</ulink></bibliomisc> + </biblioentry> + + <biblioentry> + <abbrev>ghc-fc-commentary</abbrev> + <authorgroup> + <author><surname>GHC Wiki</surname></author> + </authorgroup> + <citetitle pubwork="article">System FC: equality constraints and coercions</citetitle> + <pubdate>2006</pubdate> + <bibliomisc><ulink url="http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/FC">http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/FC</ulink></bibliomisc> + </biblioentry> + + <biblioentry> + <abbrev>ghc-api</abbrev> + <authorgroup> + <author><surname>Haskell Wiki</surname></author> + </authorgroup> + <citetitle pubwork="article">Using GHC as a library</citetitle> + <pubdate>2007</pubdate> + <bibliomisc><ulink url="http://haskell.org/haskellwiki/GHC/As_a_library">http://haskell.org/haskellwiki/GHC/As_a_library</ulink></bibliomisc> + </biblioentry> + + <biblioentry> + <abbrev>haskell98</abbrev> + <authorgroup> + <editor><firstname>Simon</firstname><surname>Peyton-Jones</surname></editor> + </authorgroup> + <citetitle pubwork="article">Haskell 98 Language and Libraries: The Revised Report</citetitle> + <publisher> + <publishername>Cambridge University Press</publishername> + <address> + <city>Cambridge></city> + <state>UK</state> + </address> + </publisher> + <pubdate>2003</pubdate> + </biblioentry> + + <biblioentry> + <abbrev>system-fc</abbrev> + <authorgroup> + <author><firstname>Martin</firstname><surname>Sulzmann</surname></author> + <author><firstname>Manuel M.T.</firstname><surname>Chakravarty</surname></author> + <author><firstname>Simon</firstname><surname>Peyton-Jones</surname></author> + <author><firstname>Kevin</firstname><surname>Donnelly</surname></author> + </authorgroup> + <citetitle pubwork="article">System F with type equality coercions</citetitle> + <publisher> + <publishername>ACM</publishername> + <address> + <city>New York</city> + <state>NY</state> + <country>USA</country> + </address> + </publisher> + <artpagenums>53-66</artpagenums> + <pubdate>2007</pubdate> + <bibliomisc><ulink url="http://portal.acm.org/citation.cfm?id=1190324">http://portal.acm.org/citation.cfm?id=1190324</ulink></bibliomisc> + <!-- booktitle = {{TLDI '07: Proceedings of the 2007 ACM SIGPLAN International Workshop on Types in Language Design and Implementation}}, --> + </biblioentry> + + <biblioentry> + <abbrev>gadts</abbrev> + <authorgroup> + <author><firstname>Simon</firstname><surname>Peyton-Jones</surname></author> + <author><firstname>Dimitrios</firstname><surname>Vytiniotis</surname></author> + <author><firstname>Stephanie</firstname><surname>Weirich</surname></author> + <author><firstname>Geoffrey</firstname><surname>Washburn</surname></author> + </authorgroup> + <citetitle pubwork="article">Simple unification-based type inference for GADTs</citetitle> + <publisher> + <publishername>ACM</publishername> + <address> + <city>New York</city> + <state>NY</state> + <country>USA</country> + </address> + </publisher> + <artpagenums>50-61</artpagenums> + <pubdate>2006</pubdate> + <bibliomisc><ulink url="http://research.microsoft.com/Users/simonpj/papers/gadt/index.htm">http://research.microsoft.com/Users/simonpj/papers/gadt/index.htm</ulink></bibliomisc> + </biblioentry> + + <biblioentry> + <abbrev>Launchbury94</abbrev> + <authorgroup> + <author><firstname>John</firstname><surname>Launchbury</surname></author> + <author><firstname>Simon L.</firstname><surname>Peyton-Jones</surname></author> + </authorgroup> + <citetitle pubwork="article">Lazy Functional State Threads</citetitle> + <artpagenums>24-35</artpagenums> + <pubdate>1994</pubdate> + <bibliomisc><ulink url="http://citeseer.ist.psu.edu/article/launchbury93lazy.html">http://citeseer.ist.psu.edu/article/launchbury93lazy.html</ulink></bibliomisc> + <!-- booktitle = "{SIGPLAN} {Conference} on {Programming Language Design and Implementation}", --> + </biblioentry> + + <biblioentry> + <abbrev>pj:unboxed</abbrev> + <authorgroup> + <author><firstname>Simon L.</firstname><surname>Peyton-Jones</surname></author> + <author><firstname>John</firstname><surname>Launchbury</surname></author> + <editor><firstname>J.</firstname><surname>Hughes</surname></editor> + </authorgroup> + <citetitle pubwork="article">Unboxed Values as First Class Citizens in a Non-strict Functional Language</citetitle> + <publisher> + <publishername>Springer-Verlag LNCS523</publishername> + <address> + <city>Cambridge</city> + <state>Massachussetts</state> + <country>USA</country> + </address> + </publisher> + <artpagenums>636-666</artpagenums> + <pubdate>1991, August 26-28</pubdate> + <bibliomisc><ulink url="http://citeseer.ist.psu.edu/jones91unboxed.html">http://citeseer.ist.psu.edu/jones91unboxed.html</ulink></bibliomisc> + <!-- booktitle = "Proceedings of the Conference on Functional Programming and Computer Architecture", --> + </biblioentry> + + <biblioentry> + <abbrev>ghc-inliner</abbrev> + <authorgroup> + <author><firstname>Simon</firstname><surname>Peyton-Jones</surname></author> + <author><firstname>Simon</firstname><surname>Marlow</surname></author> + </authorgroup> + <citetitle pubwork="article">Secrets of the Glasgow Haskell Compiler inliner</citetitle> + <pubdate>1999</pubdate> + <address> + <city>Paris</city> + <country>France</country> + </address> + <bibliomisc><ulink url="http://research.microsoft.com/Users/simonpj/Papers/inlining/inline.pdf">http://research.microsoft.com/Users/simonpj/Papers/inlining/inline.pdf</ulink></bibliomisc> + <!-- booktitle = "Workshop on Implementing Declarative Languages", --> + </biblioentry> + + <biblioentry> + <abbrev>comp-by-trans-scp</abbrev> + <authorgroup> + <author><firstname>Simon L.</firstname><surname>Peyton-Jones</surname></author> + <author><firstname>A. L. M.</firstname><surname>Santos</surname></author> + </authorgroup> + <citetitle pubwork="article">A transformation-based optimiser for Haskell</citetitle> + <citetitle pubwork="journal">Science of Computer Programming</citetitle> + <volumenum>32</volumenum> + <issuenum>1-3</issuenum> + <artpagenums>3-47</artpagenums> + <pubdate>1998</pubdate> + <bibliomisc><ulink url="http://citeseer.ist.psu.edu/peytonjones98transformationbased.html">http://citeseer.ist.psu.edu/peytonjones98transformationbased.html</ulink></bibliomisc> + </biblioentry> + + <biblioentry> + <abbrev>stg-machine</abbrev> + <authorgroup> + <author><firstname>Simon L.</firstname><surname>Peyton-Jones</surname></author> + </authorgroup> + <citetitle pubwork="article">Implementing Lazy Functional Languages on Stock Hardware: The Spineless Tagless G-Machine</citetitle> + <citetitle pubwork="journal">Journal of Functional Programming</citetitle> + <volumenum>2</volumenum> + <issuenum>2</issuenum> + <artpagenums>127-202</artpagenums> + <pubdate>1992</pubdate> + <bibliomisc><ulink url="http://citeseer.ist.psu.edu/peytonjones92implementing.html">http://citeseer.ist.psu.edu/peytonjones92implementing.html</ulink></bibliomisc> + </biblioentry> + + <biblioentry> + <abbrev>launchbury93natural</abbrev> + <authorgroup> + <author><firstname>John</firstname><surname>Launchbury</surname></author> + </authorgroup> + <citetitle pubwork="article">A Natural Semantics for Lazy Evaluation</citetitle> + <artpagenums>144-154</artpagenums> + <address> + <city>Charleston</city> + <state>South Carolina</state> + </address> + <pubdate>1993</pubdate> + <bibliomisc><ulink url="citeseer.ist.psu.edu/launchbury93natural.html">citeseer.ist.psu.edu/launchbury93natural.html</ulink></bibliomisc> + <!-- booktitle = "Conference Record of the Twentieth Annual {ACM} {SIGPLAN}-{SIGACT} Symposium on Principles of Programming Languages", --> + </biblioentry> + + <biblioentry> + <abbrev>ghcprim</abbrev> + <authorgroup> + <author><surname>The GHC Team</surname></author> + </authorgroup> + <citetitle pubwork="article">Library documentation: GHC.Prim</citetitle> + <pubdate>2008</pubdate> + <bibliomisc><ulink url="http://www.haskell.org/ghc/docs/latest/html/libraries/base/GHC-Prim.html">http://www.haskell.org/ghc/docs/latest/html/libraries/base/GHC-Prim.html</ulink></bibliomisc> + </biblioentry> + </bibliolist> + +</chapter> diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 678164136b..2425d822c9 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -160,6 +160,58 @@ foreign import ccall interruptible handle <literal>ERROR_OPERATION_ABORTED</literal>. </para> </sect2> + + <sect2 id="ffi-capi"> + <title>The CAPI calling convention</title> + <para> + The <literal>CAPI</literal> extension allows a calling + convention of <literal>capi</literal> to be used in foreign + declarations, e.g. + +<programlisting> +foreign import capi "header.h f" f :: CInt -> IO CInt +</programlisting> + + Rather than generating code to call <literal>f</literal> + according to the platform's ABI, we instead call + <literal>f</literal> using the C API defined in the header + <literal>header.h</literal>. Thus <literal>f</literal> can be + called even if it may be defined as a CPP + <literal>#define</literal> rather than a proper function. + </para> + + <para> + When using <literal>capi</literal>, it is also possible to + import values, rather than functions. For example, + +<programlisting> +foreign import capi "pi.h value pi" c_pi :: CDouble +</programlisting> + + will work regardless of whether <literal>pi</literal> is + defined as +<programlisting> +const double pi = 3.14; +</programlisting> + or with +<programlisting> +#define pi 3.14 +</programlisting> + </para> + + <para> + In order to tell GHC the C type that a Haskell type + corresponds to when it is used with the CAPI, a + <literal>CTYPE</literal> pragma can be used on the type + definition. The header which defines the type can optionally + also be specified. The syntax looks like: + +<programlisting> +data {-# CTYPE "unistd.h" "useconds_t" #-} T = ... +newtype {-# CTYPE "useconds_t" #-} T = ... +</programlisting> + </para> + </sect2> </sect1> <sect1 id="ffi-ghc"> diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index d09a794b11..b3fa469a99 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -2649,6 +2649,28 @@ bar <varlistentry> <term> + <literal>:seti</literal> <optional><replaceable>option</replaceable>...</optional> + <indexterm><primary><literal>:seti</literal></primary></indexterm> + </term> + <listitem> + <para> + Like <literal>:set</literal>, but options set with + <literal>:seti</literal> affect only expressions and + commands typed at the prompt, and not modules loaded with + <literal>:load</literal> (in contrast, options set with + <literal>:set</literal> apply everywhere). See <xref + linkend="ghci-interactive-options" />. + </para> + <para> + Without any arguments, displays the current set of options + that are applied to expressions and commands typed at the + prompt. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <literal>:show bindings</literal> <indexterm><primary><literal>:show bindings</literal></primary></indexterm> </term> @@ -2824,8 +2846,9 @@ bar </sect1> <sect1 id="ghci-set"> - <title>The <literal>:set</literal> command</title> + <title>The <literal>:set</literal> and <literal>:seti</literal> commands</title> <indexterm><primary><literal>:set</literal></primary></indexterm> + <indexterm><primary><literal>:seti</literal></primary></indexterm> <para>The <literal>:set</literal> command sets two types of options: GHCi options, which begin with @@ -2945,7 +2968,71 @@ Prelude> :set -fno-warn-incomplete-patterns -XNoMultiParamTypeClasses not take effect until the next reload.</para> <indexterm><primary>static</primary><secondary>options</secondary></indexterm> </sect2> + + <sect2 id="ghci-interactive-options"> + <title>Setting options for interactive evaluation only</title> + + <para> + GHCi actually maintains two sets of options: one set that + applies when loading modules, and another set that applies for + expressions and commands typed at the prompt. The + <literal>:set</literal> command modifies both, but there is + also a <literal>:seti</literal> command (for "set + interactive") that affects only the second set. + </para> + + <para> + The two sets of options can be inspected using the + <literal>:set</literal> and <literal>:seti</literal> commands + respectively, with no arguments. For example, in a clean GHCi + session we might see something like this: + </para> + +<screen> +Prelude> :seti +base language is: Haskell2010 +with the following modifiers: + -XNoDatatypeContexts + -XNondecreasingIndentation + -XExtendedDefaultRules +GHCi-specific dynamic flag settings: +other dynamic, non-language, flag settings: + -fimplicit-import-qualified +warning settings: +</screen> + + <para> + Note that the option <option>-XExtendedDefaultRules</option> + is on, because we apply special defaulting rules to + expressions typed at the prompt (see <xref + linkend="extended-default-rules" />). + </para> + + <para> + It is often useful to change the language options for + expressions typed at the prompt only, without having that + option apply to loaded modules too. A good example is +<screen> +:seti -XNoMonomorphismRestriction +</screen> + It would be undesirable if + <option>-XNoMonomorphismRestriction</option> were to apply to + loaded modules too: that might cause a compilation error, but + more commonly it will cause extra recompilation, because GHC + will think that it needs to recompile the module because the + flags have changed. + </para> + + <para> + It is therefore good practice if you are setting language + options in your <literal>.ghci</literal> file, to use + <literal>:seti</literal> rather than <literal>:set</literal> + unless you really do want them to apply to all modules you + load in GHCi. + </para> + </sect2> </sect1> + <sect1 id="ghci-dot-files"> <title>The <filename>.ghci</filename> file</title> <indexterm><primary><filename>.ghci</filename></primary><secondary>file</secondary> @@ -2976,7 +3063,14 @@ Prelude> :set -fno-warn-incomplete-patterns -XNoMultiParamTypeClasses <para>The <filename>ghci.conf</filename> file is most useful for turning on favourite options (eg. <literal>:set +s</literal>), and - defining useful macros. Placing a <filename>.ghci</filename> file + defining useful macros. Note: when setting language options in + this file it is usually desirable to use <literal>:seti</literal> + rather than <literal>:set</literal> (see <xref + linkend="ghci-interactive-options" />). + </para> + + <para> + Placing a <filename>.ghci</filename> file in a directory with a Haskell project is a useful way to set certain project-wide options so you don't have to type them every time you start GHCi: eg. if your project uses multi-parameter diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 135d8ecded..bcf84b4246 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -9239,7 +9239,7 @@ The following are good producers: <listitem> <para> - Enumerations of <literal>Int</literal> and <literal>Char</literal> (e.g. <literal>['a'..'z']</literal>). + Enumerations of <literal>Int</literal>, <literal>Integer</literal> and <literal>Char</literal> (e.g. <literal>['a'..'z']</literal>). </para> </listitem> <listitem> diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml index f98fe90477..d7ad9955d3 100644 --- a/docs/users_guide/phases.xml +++ b/docs/users_guide/phases.xml @@ -941,13 +941,24 @@ $ cat foo.hspp</screen> <itemizedlist> <listitem> - <para>Parallelism<indexterm><primary>parallelism</primary></indexterm> on a multiprocessor<indexterm><primary>multiprocessor</primary></indexterm><indexterm><primary>SMP</primary></indexterm> or multicore<indexterm><primary>multicore</primary></indexterm> - machine. See <xref linkend="using-smp" />.</para> - - <para>The ability to make a foreign call that does not - block all other Haskell threads, and to invoke - foreign-exported Haskell functions from multiple OS - threads. See <xref linkend="ffi-threads" />.</para> + <para>It enables the <option>-N</option><indexterm><primary><option>-N<replaceable>x</replaceable></option></primary><secondary>RTS option</secondary></indexterm> RTS option to be + used, which allows threads to run in + parallel<indexterm><primary>parallelism</primary></indexterm> + on a + multiprocessor<indexterm><primary>multiprocessor</primary></indexterm><indexterm><primary>SMP</primary></indexterm> + or + multicore<indexterm><primary>multicore</primary></indexterm> + machine. See <xref linkend="using-smp" />.</para> + </listitem> + <listitem> + <para>If a thread makes a foreign call (and the call is + not marked <literal>unsafe</literal>), then other + Haskell threads in the program will continue to run + while the foreign call is in progress. + Additionally, <literal>foreign export</literal>ed + Haskell functions may be called from multiple OS + threads simultaneously. See + <xref linkend="ffi-threads" />.</para> </listitem> </itemizedlist> </listitem> diff --git a/docs/users_guide/ug-book.xml.in b/docs/users_guide/ug-book.xml.in index 1ff487c2ed..4d4489f80f 100644 --- a/docs/users_guide/ug-book.xml.in +++ b/docs/users_guide/ug-book.xml.in @@ -17,6 +17,7 @@ &lang-features; &ffi-chap; &extending-ghc; +&external-core; &wrong; &utils; &win32-dll; diff --git a/docs/users_guide/ug-ent.xml.in b/docs/users_guide/ug-ent.xml.in index c83abaad52..37df56889b 100644 --- a/docs/users_guide/ug-ent.xml.in +++ b/docs/users_guide/ug-ent.xml.in @@ -12,6 +12,7 @@ <!ENTITY sooner SYSTEM "sooner.xml" > <!ENTITY lang-features SYSTEM "lang.xml" > <!ENTITY glasgowexts SYSTEM "glasgow_exts.xml" > +<!ENTITY external-core SYSTEM "external_core.xml" > <!ENTITY packages SYSTEM "packages.xml" > <!ENTITY parallel SYSTEM "parallel.xml" > <!ENTITY safehaskell SYSTEM "safe_haskell.xml" > @@ -28,3 +29,4 @@ <!ENTITY libraryBaseLocation "../libraries/base-@LIBRARY_base_VERSION@"> <!ENTITY libraryCabalLocation "../libraries/Cabal-@LIBRARY_Cabal_VERSION@"> <!ENTITY libraryGhcPrimLocation "../libraries/ghc-prim-@LIBRARY_ghc_prim_VERSION@"> +<!ENTITY arw "->"> diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index ca28fc3888..234b64d736 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -2049,6 +2049,35 @@ f "2" = 2 <ulink url="&libraryBaseLocation;/Control-Concurrent.html"><literal>Control.Concurrent</literal></ulink>. More information on Concurrent Haskell is provided in the documentation for that module.</para> + <para> + Optionally, the program may be linked with + the <option>-threaded</option> option (see + <xref linkend="options-linker" />. This provides two benefits: + + <itemizedlist> + <listitem> + <para>It enables the <option>-N</option><indexterm><primary><option>-N<replaceable>x</replaceable></option></primary><secondary>RTS option</secondary></indexterm> RTS option to be + used, which allows threads to run in + parallel<indexterm><primary>parallelism</primary></indexterm> + on a + multiprocessor<indexterm><primary>multiprocessor</primary></indexterm><indexterm><primary>SMP</primary></indexterm> + or + multicore<indexterm><primary>multicore</primary></indexterm> + machine. See <xref linkend="using-smp" />.</para> + </listitem> + <listitem> + <para>If a thread makes a foreign call (and the call is + not marked <literal>unsafe</literal>), then other + Haskell threads in the program will continue to run + while the foreign call is in progress. + Additionally, <literal>foreign export</literal>ed + Haskell functions may be called from multiple OS + threads simultaneously. See + <xref linkend="ffi-threads" />.</para> + </listitem> + </itemizedlist> + </para> + <para>The following RTS option(s) affect the behaviour of Concurrent Haskell programs:<indexterm><primary>RTS options, concurrent</primary></indexterm></para> @@ -2177,17 +2206,10 @@ f "2" = 2 enabling the parallel garbage collector (see <xref linkend="rts-options-gc" />).</para> - <para>There is no means (currently) by which this value - may vary after the program has started.</para> - <para>The current value of the <option>-N</option> option is available to the Haskell program via <literal>Control.Concurrent.getNumCapabilities</literal>, and it may be changed while the program is running by - calling <literal>Control.Concurrent.setNumCapabilities</literal>. - Note: in the current implementation, - the <option>-N</option> value may only - be <emphasis>increased</emphasis>, not decreased, by calling <literal>Control.Concurrent.setNumCapabilities</literal>.</para> </listitem> </varlistentry> @@ -16,7 +16,6 @@ # * remove old Makefiles, add new stubs for building in subdirs # * docs/Makefile # * docs/docbook-cheat-sheet/Makefile -# * docs/ext-core/Makefile # * docs/man/Makefile # * docs/storage-mgmt/Makefile # * docs/vh/Makefile @@ -55,7 +54,7 @@ # o register each package into inplace/lib/package.conf # * build libffi # * With bootstrapping compiler: -# o Build libraries/{filepath,hpc,extensible-exceptions,Cabal} +# o Build libraries/{filepath,hpc,Cabal} # o Build compiler (stage 1) # * With stage 1: # o Build libraries/* @@ -334,7 +333,7 @@ PKGS_THAT_USE_TH := $(PKGS_THAT_ARE_DPH) # # We assume that the stage0 compiler has a suitable bytestring package, # so we don't have to include it below. -PKGS_THAT_BUILD_WITH_STAGE0 = Cabal/Cabal hpc extensible-exceptions binary bin-package-db hoopl +PKGS_THAT_BUILD_WITH_STAGE0 = Cabal/Cabal hpc binary bin-package-db hoopl # $(EXTRA_PACKAGES) is another classification, of packages built but # not installed @@ -399,8 +398,8 @@ endif $(eval $(call addPackage,base)) $(eval $(call addPackage,filepath)) $(eval $(call addPackage,array)) -$(eval $(call addPackage,bytestring)) $(eval $(call addPackage,deepseq)) +$(eval $(call addPackage,bytestring)) $(eval $(call addPackage,containers)) $(eval $(call addPackage,Win32,($$(Windows),YES))) @@ -411,7 +410,6 @@ $(eval $(call addPackage,old-time)) $(eval $(call addPackage,time)) $(eval $(call addPackage,directory)) $(eval $(call addPackage,process)) -$(eval $(call addPackage,extensible-exceptions)) $(eval $(call addPackage,haskell98)) $(eval $(call addPackage,haskell2010)) $(eval $(call addPackage,hpc)) @@ -440,7 +438,7 @@ $(eval $(call extra-packages)) # # Ideally we should use the correct dependencies here to allow more # parallelism, but we don't know the dependencies until we've -# generated the pacakge-data.mk files. +# generated the package-data.mk files. define fixed_pkg_dep libraries/$1/$2/package-data.mk : $$(GHC_PKG_INPLACE) $$(fixed_pkg_prev) fixed_pkg_prev:=libraries/$1/$2/package-data.mk @@ -561,7 +559,6 @@ endif BUILD_DIRS += \ docs/users_guide \ - docs/ext-core \ docs/man \ $(GHC_UNLIT_DIR) \ $(GHC_HP2PS_DIR) diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index f1767c3ea5..11d23a6876 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -16,13 +16,12 @@ module GhciMonad ( Command, BreakLocation(..), TickArray, - setDynFlags, + getDynFlags, runStmt, runDecls, resume, timeIt, recordBreak, revertCAFs, printForUser, printForUserPartWay, prettyLocations, initInterpBuffering, turnOffBuffering, flushInterpBuffers, - ghciHandleGhcException, ) where #include "HsVersions.h" @@ -31,7 +30,6 @@ import qualified GHC import GhcMonad hiding (liftIO) import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable -import Panic hiding (showException) import Util import DynFlags import HscTypes @@ -171,9 +169,6 @@ instance Monad GHCi where instance Functor GHCi where fmap f m = m >>= return . f -ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a -ghciHandleGhcException = handleGhcException - getGHCiState :: GHCi GHCiState getGHCiState = GHCi $ \r -> liftIO $ readIORef r setGHCiState :: GHCiState -> GHCi () @@ -234,10 +229,6 @@ instance ExceptionMonad (InputT GHCi) where gblock = Haskeline.block gunblock = Haskeline.unblock -setDynFlags :: DynFlags -> GHCi [PackageId] -setDynFlags dflags = do - GHC.setSessionDynFlags dflags - isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt = do st <- getGHCiState diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 3d0adacf6b..045c6a6af4 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -126,7 +126,7 @@ builtin_commands = [ ("def", keepGoing (defineMacro False), completeExpression), ("def!", keepGoing (defineMacro True), completeExpression), ("delete", keepGoing deleteCmd, noCompletion), - ("edit", keepGoing editFile, completeFilename), + ("edit", keepGoing' editFile, completeFilename), ("etags", keepGoing createETagsFileCmd, completeFilename), ("force", keepGoing forceCmd, completeExpression), ("forward", keepGoing forwardCmd, noCompletion), @@ -146,7 +146,9 @@ builtin_commands = [ ("run", keepGoing runRun, completeFilename), ("script", keepGoing' scriptCmd, completeFilename), ("set", keepGoing setCmd, completeSetOptions), + ("seti", keepGoing setiCmd, completeSeti), ("show", keepGoing showCmd, completeShowOptions), + ("showi", keepGoing showiCmd, completeShowiOptions), ("sprint", keepGoing sprintCmd, completeExpression), ("step", keepGoing stepCmd, completeIdentifier), ("steplocal", keepGoing stepLocalCmd, completeIdentifier), @@ -253,6 +255,7 @@ helpText = " -- Commands for changing settings:\n" ++ "\n" ++ " :set <option> ... set options\n" ++ + " :seti <option> ... set options for interactive evaluation only\n" ++ " :set args <arg> ... set the arguments returned by System.getArgs\n" ++ " :set prog <progname> set the value returned by System.getProgName\n" ++ " :set prompt <prompt> set the prompt used in GHCi\n" ++ @@ -279,9 +282,10 @@ helpText = " :show imports show the current imports\n" ++ " :show modules show the currently loaded modules\n" ++ " :show packages show the currently active package flags\n" ++ - " :show languages show the currently active language flags\n" ++ + " :show language show the currently active language flags\n" ++ " :show <setting> show value of <setting>, which is one of\n" ++ " [args, prog, prompt, editor, stop]\n" ++ + " :showi language show language flags for interactive evaluation\n" ++ "\n" findEditor :: IO String @@ -330,6 +334,11 @@ interactiveUI srcs maybe_exprs = do -- Initialise buffering for the *interpreted* I/O system initInterpBuffering + -- The initial set of DynFlags used for interactive evaluation is the same + -- as the global DynFlags, plus -XExtendedDefaultRules + dflags <- getDynFlags + GHC.setInteractiveDynFlags (xopt_set dflags Opt_ExtendedDefaultRules) + liftIO $ when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): @@ -421,7 +430,7 @@ runGHCi paths maybe_exprs = do getDirectory f = case takeDirectory f of "" -> "."; d -> d -- - setGHCContext [] + setGHCContextFromGHCiState when (read_dot_files) $ do mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] @@ -575,8 +584,7 @@ mkPrompt = do rev_imports = reverse imports -- rightmost are the most recent modules_bit = - hsep [ char '*' <> ppr (GHC.moduleName m) - | IIModule m <- rev_imports ] <+> + hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+> hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ]) -- use the 'as' name if there is one @@ -1045,15 +1053,16 @@ trySuccess act = ----------------------------------------------------------------------------- -- :edit -editFile :: String -> GHCi () +editFile :: String -> InputT GHCi () editFile str = - do file <- if null str then chooseEditFile else return str - st <- getGHCiState + do file <- if null str then lift chooseEditFile else return str + st <- lift getGHCiState let cmd = editor st when (null cmd) $ ghcError (CmdLineError "editor not set, use :set editor") - _ <- liftIO $ system (cmd ++ ' ':file) - return () + code <- liftIO $ system (cmd ++ ' ':file) + when (code == ExitSuccess) + $ reloadModule "" -- The user didn't specify a file so we pick one for them. -- Our strategy is to pick the first module that failed to load, @@ -1285,8 +1294,13 @@ setContextAfterLoad keep_ctxt ms = do load_this summary | m <- GHC.ms_mod summary = do is_interp <- GHC.moduleIsInterpreted m - let new_ctx | is_interp = [IIModule m] - | otherwise = [IIDecl $ simpleImportDecl (GHC.moduleName m)] + dflags <- getDynFlags + let star_ok = is_interp && not (safeLanguageOn dflags) + -- We import the module with a * iff + -- - it is interpreted, and + -- - -XSafe is off (it doesn't allow *-imports) + let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] + | otherwise = [mkIIDecl (GHC.moduleName m)] setContextKeepingPackageModules keep_ctxt new_ctx @@ -1304,7 +1318,7 @@ setContextKeepingPackageModules keep_ctx trans_ctx = do new_rem_ctx <- if keep_ctx then return rem_ctx else keepPackageImports rem_ctx setGHCiState st{ remembered_ctx = new_rem_ctx, - transient_ctx = trans_ctx } + transient_ctx = filterSubsumed new_rem_ctx trans_ctx } setGHCContextFromGHCiState @@ -1502,7 +1516,7 @@ guessCurrentModule cmd when (null imports) $ ghcError $ CmdLineError (':' : cmd ++ ": no current module") case (head imports) of - IIModule m -> return m + IIModule m -> GHC.findModule m Nothing IIDecl d -> GHC.findModule (unLoc (ideclName d)) (ideclPkgQual d) -- without bang, show items in context of their parents and omit children @@ -1609,68 +1623,82 @@ moduleCmd str sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m - starred ('*':m) = Left m - starred m = Right m + starred ('*':m) = Left (GHC.mkModuleName m) + starred m = Right (GHC.mkModuleName m) -addModulesToContext :: [String] -> [String] -> GHCi () -addModulesToContext as bs = do - mapM_ (add True) as - mapM_ (add False) bs + +-- ----------------------------------------------------------------------------- +-- Four ways to manipulate the context: +-- (a) :module +<stuff>: addModulesToContext +-- (b) :module -<stuff>: remModulesFromContext +-- (c) :module <stuff>: setContext +-- (d) import <module>...: addImportToContext + +addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi () +addModulesToContext starred unstarred = do + mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) setGHCContextFromGHCiState - where - add :: Bool -> String -> GHCi () - add star str = do - i <- checkAdd star str - modifyGHCiState $ \st -> - st { remembered_ctx = addNotSubsumed i (remembered_ctx st) } -remModulesFromContext :: [String] -> [String] -> GHCi () -remModulesFromContext as bs = do - mapM_ rm (as ++ bs) +remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi () +remModulesFromContext starred unstarred = do + mapM_ rm (starred ++ unstarred) setGHCContextFromGHCiState where - rm :: String -> GHCi () + rm :: ModuleName -> GHCi () rm str = do - m <- moduleName <$> lookupModule str + m <- moduleName <$> lookupModuleName str let filt = filter ((/=) m . iiModuleName) modifyGHCiState $ \st -> st { remembered_ctx = filt (remembered_ctx st) , transient_ctx = filt (transient_ctx st) } +setContext :: [ModuleName] -> [ModuleName] -> GHCi () +setContext starred unstarred = do + modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] } + -- delete the transient context + addModulesToContext starred unstarred + addImportToContext :: String -> GHCi () addImportToContext str = do idecl <- GHC.parseImportDecl str - _ <- GHC.lookupModule (unLoc (ideclName idecl)) Nothing -- #5836 - modifyGHCiState $ \st -> - st { remembered_ctx = addNotSubsumed (IIDecl idecl) (remembered_ctx st) } + addII (IIDecl idecl) -- #5836 setGHCContextFromGHCiState --- TODO: ARGH! This is a mess! 'checkAdd' is called from many places and we --- have about 4 different variants of setGHCContext. All this import code needs --- to be refactored to something saner. We should do the sanity check on an --- import in 'checkAdd' and checkAdd only and only need to call checkAdd from --- one place ('setGHCContetFromGHCiState'). The code isn't even logically --- ordered! -checkAdd :: Bool -> String -> GHCi (InteractiveImport) -checkAdd star mstr = do - dflags <- getDynFlags - case safeLanguageOn dflags of - True | star -> do - liftIO $ putStrLn "Warning: can't use * imports with Safe Haskell; ignoring *" - checkAdd False mstr +-- Util used by addImportToContext and addModulesToContext +addII :: InteractiveImport -> GHCi () +addII iidecl = do + checkAdd iidecl + modifyGHCiState $ \st -> + st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st) + , transient_ctx = filter (not . (iidecl `iiSubsumes`)) + (transient_ctx st) + } - True -> do m <- lookupModule mstr - s <- GHC.isModuleTrusted m - case s of - True -> return $ IIDecl (simpleImportDecl $ moduleName m) - False -> ghcError $ CmdLineError $ - "can't import " ++ mstr ++ " as it isn't trusted." +-- ----------------------------------------------------------------------------- +-- Validate a module that we want to add to the context + +checkAdd :: InteractiveImport -> GHCi () +checkAdd ii = do + dflags <- getDynFlags + let safe = safeLanguageOn dflags + case ii of + IIModule modname + | safe -> ghcError $ CmdLineError "can't use * imports with Safe Haskell" + | otherwise -> wantInterpretedModuleName modname >> return () + + IIDecl d -> do + let modname = unLoc (ideclName d) + m <- lookupModuleName modname + when safe $ do + t <- GHC.isModuleTrusted m + when (not t) $ + ghcError $ CmdLineError $ + "can't import " ++ moduleNameString modname + ++ " as it isn't trusted." - False | star -> do m <- wantInterpretedModule mstr - return $ IIModule m - False -> do m <- lookupModule mstr - return $ IIDecl (simpleImportDecl $ moduleName m) +-- ----------------------------------------------------------------------------- +-- Update the GHC API's view of the context -- | Sets the GHC context from the GHCi state. The GHC context is -- always set this way, we never modify it incrementally. @@ -1687,61 +1715,36 @@ checkAdd star mstr = do setGHCContextFromGHCiState :: GHCi () setGHCContextFromGHCiState = do st <- getGHCiState - goodTran <- mapMaybeM (tryBool . ok) $ transient_ctx st - goodRemb <- mapMaybeM (tryBool . ok) $ remembered_ctx st - -- drop bad imports so we don't keep replaying it to the user! - modifyGHCiState $ \s -> s { transient_ctx = goodTran } - modifyGHCiState $ \s -> s { remembered_ctx = goodRemb } - setGHCContext (goodTran ++ goodRemb) - - where - ok (IIModule m) = checkAdd True (moduleNameString (moduleName m)) - ok (IIDecl d) = checkAdd False (moduleNameString (unLoc (ideclName d))) - - mapMaybeM f xs = catMaybes `fmap` sequence (map f xs) - -setContext :: [String] -> [String] -> GHCi () -setContext starred not_starred = do - is1 <- mapM (checkAdd True) starred - is2 <- mapM (checkAdd False) not_starred - let iss = foldr addNotSubsumed [] (is1++is2) - modifyGHCiState $ \st -> st { remembered_ctx = iss, transient_ctx = [] } - -- delete the transient context - setGHCContextFromGHCiState + -- re-use checkAdd to check whether the module is valid. If the + -- module does not exist, we do *not* want to print an error + -- here, we just want to silently keep the module in the context + -- until such time as the module reappears again. So we ignore + -- the actual exception thrown by checkAdd, using tryBool to + -- turn it into a Bool. + iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st) + GHC.setContext (maybeAddPrelude iidecls) + where + maybeAddPrelude :: [InteractiveImport] -> [InteractiveImport] + maybeAddPrelude iidecls + | any isPreludeImport iidecls = iidecls + | otherwise = iidecls ++ [implicitPreludeImport] + -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up. --- | Sets the GHC contexts to the given set of imports, adding a Prelude --- import if there isn't an explicit one already. -setGHCContext :: [InteractiveImport] -> GHCi () -setGHCContext iidecls = GHC.setContext (iidecls ++ prel) - -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up. - where - prel | any isPreludeImport iidecls = [] - | otherwise = [implicitPreludeImport] -- ----------------------------------------------------------------------------- -- Utils on InteractiveImport --- | Returns True if the left import subsumes the right one. Doesn't --- need to be 100% accurate, conservatively returning False is fine. --- --- Note that an IIModule does not necessarily subsume an IIDecl, --- because e.g. a module might export a name that is only available --- qualified within the module itself. --- -iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool -iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 -iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude - = unLoc (ideclName d1) == unLoc (ideclName d2) - && ideclAs d1 == ideclAs d2 - && (not (ideclQualified d1) || ideclQualified d2) - && (isNothing (ideclHiding d1) || ideclHiding d1 == ideclHiding d2) -iiSubsumes _ _ = False +mkIIModule :: ModuleName -> InteractiveImport +mkIIModule = IIModule -iiModules :: [InteractiveImport] -> [Module] +mkIIDecl :: ModuleName -> InteractiveImport +mkIIDecl = IIDecl . simpleImportDecl + +iiModules :: [InteractiveImport] -> [ModuleName] iiModules is = [m | IIModule m <- is] iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = moduleName m +iiModuleName (IIModule m) = m iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName @@ -1760,6 +1763,31 @@ addNotSubsumed i is | any (`iiSubsumes` i) is = is | otherwise = i : filter (not . (i `iiSubsumes`)) is +-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed +-- by any of @is@. +filterSubsumed :: [InteractiveImport] -> [InteractiveImport] + -> [InteractiveImport] +filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js + +-- | Returns True if the left import subsumes the right one. Doesn't +-- need to be 100% accurate, conservatively returning False is fine. +-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in +-- plusProv will ensue (#5904)) +-- +-- Note that an IIModule does not necessarily subsume an IIDecl, +-- because e.g. a module might export a name that is only available +-- qualified within the module itself. +-- +iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool +iiSubsumes (IIModule m1) (IIModule m2) = m1==m2 +iiSubsumes (IIDecl d1) (IIDecl d2) -- A bit crude + = unLoc (ideclName d1) == unLoc (ideclName d2) + && ideclAs d1 == ideclAs d2 + && (not (ideclQualified d1) || ideclQualified d2) + && (isNothing (ideclHiding d1) || ideclHiding d1 == ideclHiding d2) +iiSubsumes _ _ = False + + ---------------------------------------------------------------------------- -- :set @@ -1771,7 +1799,35 @@ addNotSubsumed i is -- figure out which ones & disallow them. setCmd :: String -> GHCi () -setCmd "" +setCmd "" = showOptions False +setCmd "-a" = showOptions True +setCmd str + = case getCmd str of + Right ("args", rest) -> + case toArgs rest of + Left err -> liftIO (hPutStrLn stderr err) + Right args -> setArgs args + Right ("prog", rest) -> + case toArgs rest of + Right [prog] -> setProg prog + _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>") + Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest + Right ("editor", rest) -> setEditor $ dropWhile isSpace rest + Right ("stop", rest) -> setStop $ dropWhile isSpace rest + _ -> case toArgs str of + Left err -> liftIO (hPutStrLn stderr err) + Right wds -> setOptions wds + +setiCmd :: String -> GHCi () +setiCmd "" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False +setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True +setiCmd str = + case toArgs str of + Left err -> liftIO (hPutStrLn stderr err) + Right wds -> newDynFlags True wds + +showOptions :: Bool -> GHCi () +showOptions show_all = do st <- getGHCiState let opts = options st liftIO $ putStrLn (showSDoc ( @@ -1780,26 +1836,30 @@ setCmd "" then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) - dflags <- getDynFlags - liftIO $ putStrLn (showSDoc ( - text "GHCi-specific dynamic flag settings:" $$ - nest 2 (vcat (map (flagSetting dflags) ghciFlags)) - )) - liftIO $ putStrLn (showSDoc ( - text "other dynamic, non-language, flag settings:" $$ - nest 2 (vcat (map (flagSetting dflags) others)) - )) - liftIO $ putStrLn (showSDoc ( - text "warning settings:" $$ - nest 2 (vcat (map (warnSetting dflags) DynFlags.fWarningFlags)) - )) + getDynFlags >>= liftIO . showDynFlags show_all + + +showDynFlags :: Bool -> DynFlags -> IO () +showDynFlags show_all dflags = do + showLanguages' show_all dflags + putStrLn $ showSDoc $ + text "GHCi-specific dynamic flag settings:" $$ + nest 2 (vcat (map (setting dopt) ghciFlags)) + putStrLn $ showSDoc $ + text "other dynamic, non-language, flag settings:" $$ + nest 2 (vcat (map (setting dopt) others)) + putStrLn $ showSDoc $ + text "warning settings:" $$ + nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags)) + where + setting test (str, f, _) + | quiet = empty + | is_on = fstr str + | otherwise = fnostr str + where is_on = test f dflags + quiet = not show_all && test f default_dflags == is_on - where flagSetting dflags (str, f, _) - | dopt f dflags = fstr str - | otherwise = fnostr str - warnSetting dflags (str, f, _) - | wopt f dflags = fstr str - | otherwise = fnostr str + default_dflags = defaultDynFlags (settings dflags) fstr str = text "-f" <> text str fnostr str = text "-fno-" <> text str @@ -1812,22 +1872,6 @@ setCmd "" ,Opt_BreakOnError ,Opt_PrintEvldWithShow ] -setCmd str - = case getCmd str of - Right ("args", rest) -> - case toArgs rest of - Left err -> liftIO (hPutStrLn stderr err) - Right args -> setArgs args - Right ("prog", rest) -> - case toArgs rest of - Right [prog] -> setProg prog - _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>") - Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest - Right ("editor", rest) -> setEditor $ dropWhile isSpace rest - Right ("stop", rest) -> setStop $ dropWhile isSpace rest - _ -> case toArgs str of - Left err -> liftIO (hPutStrLn stderr err) - Right wds -> setOptions wds setArgs, setOptions :: [String] -> GHCi () setProg, setEditor, setStop, setPrompt :: String -> GHCi () @@ -1878,32 +1922,48 @@ setOptions wds = let (plus_opts, minus_opts) = partitionWith isPlus wds mapM_ setOpt plus_opts -- then, dynamic flags - newDynFlags minus_opts + newDynFlags False minus_opts -newDynFlags :: [String] -> GHCi () -newDynFlags minus_opts = do - dflags0 <- getDynFlags - let pkg_flags = packageFlags dflags0 - (dflags1, leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags0 $ map noLoc minus_opts - liftIO $ handleFlagWarnings dflags1 warns +newDynFlags :: Bool -> [String] -> GHCi () +newDynFlags interactive_only minus_opts = do + let lopts = map noLoc minus_opts + idflags0 <- GHC.getInteractiveDynFlags + (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts + + liftIO $ handleFlagWarnings idflags1 warns when (not $ null leftovers) (ghcError . CmdLineError $ "Some flags have not been recognized: " ++ (concat . intersperse ", " $ map unLoc leftovers)) - new_pkgs <- setDynFlags dflags1 - - -- if the package flags changed, we should reset the context - -- and link the new packages. - dflags2 <- getDynFlags - when (packageFlags dflags2 /= pkg_flags) $ do - liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." - GHC.setTargets [] - _ <- GHC.load LoadAllTargets - liftIO (linkPackages dflags2 new_pkgs) - -- package flags changed, we can't re-use any of the old context - setContextAfterLoad False [] + when (interactive_only && + packageFlags idflags1 /= packageFlags idflags0) $ do + liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set" + GHC.setInteractiveDynFlags idflags1 + + dflags0 <- getDynFlags + when (not interactive_only) $ do + (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts + new_pkgs <- GHC.setProgramDynFlags dflags1 + + -- if the package flags changed, reset the context and link + -- the new packages. + dflags2 <- getDynFlags + when (packageFlags dflags2 /= packageFlags dflags0) $ do + liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." + GHC.setTargets [] + _ <- GHC.load LoadAllTargets + liftIO $ linkPackages dflags2 new_pkgs + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad False [] + -- and copy the package state to the interactive DynFlags + idflags <- GHC.getInteractiveDynFlags + GHC.setInteractiveDynFlags + idflags{ pkgState = pkgState dflags2 + , pkgDatabase = pkgDatabase dflags2 + , packageFlags = packageFlags dflags2 } + return () @@ -1934,7 +1994,7 @@ unsetOptions str mapM_ unsetOpt plus_opts no_flags <- mapM no_flag minus_opts - newDynFlags no_flags + newDynFlags False no_flags isMinus :: String -> Bool isMinus ('-':_) = True @@ -1974,6 +2034,8 @@ optToStr RevertCAFs = "r" -- :show showCmd :: String -> GHCi () +showCmd "" = showOptions False +showCmd "-a" = showOptions True showCmd str = do st <- getGHCiState case words str of @@ -1989,9 +2051,19 @@ showCmd str = do ["breaks"] -> showBkptTable ["context"] -> showContext ["packages"] -> showPackages - ["languages"] -> showLanguages + ["languages"] -> showLanguages -- backwards compat + ["language"] -> showLanguages + ["lang"] -> showLanguages -- useful abbreviation _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ - " | breaks | context | packages | languages ]")) + " | breaks | context | packages | language ]")) + +showiCmd :: String -> GHCi () +showiCmd str = do + case words str of + ["languages"] -> showiLanguages -- backwards compat + ["language"] -> showiLanguages + ["lang"] -> showiLanguages -- useful abbreviation + _ -> ghcError (CmdLineError ("syntax: :showi language")) showImports :: GHCi () showImports = do @@ -2000,7 +2072,7 @@ showImports = do trans_ctx = transient_ctx st show_one (IIModule star_m) - = ":module +*" ++ moduleNameString (moduleName star_m) + = ":module +*" ++ moduleNameString star_m show_one (IIDecl imp) = showSDoc (ppr imp) prel_imp @@ -2083,18 +2155,42 @@ showPackages = do showFlag (DistrustPackage p) = text $ " -distrust " ++ p showLanguages :: GHCi () -showLanguages = do - dflags <- getDynFlags - liftIO $ putStrLn $ showSDoc $ vcat $ - text "active language flags:" : - [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, xopt f dflags] - +showLanguages = getDynFlags >>= liftIO . showLanguages' False + +showiLanguages :: GHCi () +showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False + +showLanguages' :: Bool -> DynFlags -> IO () +showLanguages' show_all dflags = + putStrLn $ showSDoc $ vcat + [ text "base language is: " <> + case language dflags of + Nothing -> text "Haskell2010" + Just Haskell98 -> text "Haskell98" + Just Haskell2010 -> text "Haskell2010" + , (if show_all then text "all active language options:" + else text "with the following modifiers:") $$ + nest 2 (vcat (map (setting xopt) DynFlags.xFlags)) + ] + where + setting test (str, f, _) + | quiet = empty + | is_on = text "-X" <> text str + | otherwise = text "-XNo" <> text str + where is_on = test f dflags + quiet = not show_all && test f default_dflags == is_on + + default_dflags = + defaultDynFlags (settings dflags) `lang_set` + case language dflags of + Nothing -> Just Haskell2010 + other -> other -- ----------------------------------------------------------------------------- -- Completion completeCmd, completeMacro, completeIdentifier, completeModule, - completeSetModule, + completeSetModule, completeSeti, completeShowiOptions, completeHomeModule, completeSetOptions, completeShowOptions, completeHomeModuleOrFile, completeExpression :: CompletionFunc GHCi @@ -2166,11 +2262,18 @@ completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do where opts = "args":"prog":"prompt":"editor":"stop":flagList flagList = map head $ group $ sort allFlags +completeSeti = wrapCompleter flagWordBreakChars $ \w -> do + return (filter (w `isPrefixOf`) flagList) + where flagList = map head $ group $ sort allFlags + completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) where opts = ["args", "prog", "prompt", "editor", "stop", "modules", "bindings", "linker", "breaks", - "context", "packages", "languages"] + "context", "packages", "language"] + +completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do + return (filter (w `isPrefixOf`) ["language"]) completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars $ unionComplete (fmap (map simpleCompletion) . listHomeModules) @@ -2367,10 +2470,11 @@ breakSwitch (arg1:rest) | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (md : _) -> breakByModuleLine md (read arg1) rest + (mn : _) -> do + md <- lookupModuleName mn + breakByModuleLine md (read arg1) rest [] -> do - liftIO $ putStrLn "Cannot find default module for breakpoint." - liftIO $ putStrLn "Perhaps no modules are loaded for debugging?" + liftIO $ putStrLn "No modules are loaded with debugging support." | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) @@ -2529,7 +2633,9 @@ list2 [arg] | all isDigit arg = do imports <- GHC.getContext case iiModules imports of [] -> liftIO $ putStrLn "No module to list" - (md : _) -> listModuleLine md (read arg) + (mn : _) -> do + md <- lift $ lookupModuleName mn + listModuleLine md (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do md <- wantInterpretedModule arg1 listModuleLine md (read arg2) @@ -2756,18 +2862,21 @@ ghciHandle h m = Haskeline.catch m $ \e -> unblock (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) -tryBool :: GHCi a -> GHCi (Maybe a) +tryBool :: GHCi a -> GHCi Bool tryBool m = do r <- ghciTry m case r of - Left e -> showException e >> return Nothing - Right a -> return $ Just a + Left _ -> return False + Right _ -> return True -- ---------------------------------------------------------------------------- -- Utils lookupModule :: GHC.GhcMonad m => String -> m Module -lookupModule mName = GHC.lookupModule (GHC.mkModuleName mName) Nothing +lookupModule mName = lookupModuleName (GHC.mkModuleName mName) + +lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module +lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool isHomeModule m = GHC.modulePackageId m == mainPackageId @@ -2790,8 +2899,12 @@ expandPathIO p = return other wantInterpretedModule :: GHC.GhcMonad m => String -> m Module -wantInterpretedModule str = do - modl <- lookupModule str +wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) + +wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module +wantInterpretedModuleName modname = do + modl <- lookupModuleName modname + let str = moduleNameString modname dflags <- getDynFlags when (GHC.modulePackageId modl /= thisPackage dflags) $ ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) diff --git a/ghc/Main.hs b/ghc/Main.hs index a1943cff50..a8202f2853 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -78,7 +78,7 @@ import Data.Maybe main :: IO () main = do hSetBuffering stdout NoBuffering - GHC.defaultErrorHandler defaultLogAction $ do + GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -155,6 +155,8 @@ main' postLoadMode dflags0 args flagWarnings = do -- turn on -fimplicit-import-qualified for GHCi now, so that it -- can be overriden from the command-line + -- XXX: this should really be in the interactive DynFlags, but + -- we don't set that until later in interactiveUI dflags1a | DoInteractive <- postLoadMode = imp_qual_enabled | DoEval _ <- postLoadMode = imp_qual_enabled | otherwise = dflags1 @@ -253,6 +255,10 @@ partition_args (arg:args) srcs objs - module names (not forgetting hierarchical module names), + - things beginning with '-' are flags that were not recognised by + the flag parser, and we want them to generate errors later in + checkOptions, so we class them as source files (#5921) + - and finally we consider everything not containing a '.' to be a comp manager input, as shorthand for a .hs or .lhs filename. @@ -262,6 +268,7 @@ partition_args (arg:args) srcs objs looks_like_an_input :: String -> Bool looks_like_an_input m = isSourceFilename m || looksLikeModuleName m + || "-" `isPrefixOf` m || '.' `notElem` m -- ----------------------------------------------------------------------------- diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 0cf51d05e1..1c898f256f 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -27,7 +27,7 @@ Executable ghc Main-Is: Main.hs Build-Depends: base >= 3 && < 5, array >= 0.1 && < 0.5, - bytestring >= 0.9 && < 0.10, + bytestring >= 0.9 && < 0.11, directory >= 1 && < 1.2, process >= 1 && < 1.2, filepath >= 1 && < 1.4, diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 022ee85a84..ede5687dc6 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -148,7 +148,7 @@ INSTALL_LIBS += settings ifeq "$(Windows)" "NO" install: install_ghc_link -.PNONY: install_ghc_link +.PHONY: install_ghc_link install_ghc_link: $(call removeFiles,"$(DESTDIR)$(bindir)/ghc") $(LN_S) $(CrossCompilePrefix)ghc-$(ProjectVersion) "$(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc" diff --git a/includes/Stg.h b/includes/Stg.h index 5f1f0799c5..4faed91c42 100644 --- a/includes/Stg.h +++ b/includes/Stg.h @@ -91,7 +91,7 @@ /* * The C backend likes to refer to labels by just mentioning their - * names. Howevver, when a symbol is declared as a variable in C, the + * names. However, when a symbol is declared as a variable in C, the * C compiler will implicitly dereference it when it occurs in source. * So we must subvert this behaviour for .hc files by declaring * variables as arrays, which eliminates the implicit dereference. diff --git a/includes/ghc.mk b/includes/ghc.mk index 74edf55b1c..73704b4c23 100644 --- a/includes/ghc.mk +++ b/includes/ghc.mk @@ -37,10 +37,6 @@ ifeq "$(GhcUnregisterised)" "YES" includes_CC_OPTS += -DNO_REGS -DUSE_MINIINTERPRETER endif -ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO" -includes_CC_OPTS += -DTABLES_NEXT_TO_CODE -endif - includes_CC_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS)) includes_CC_OPTS += -Irts @@ -48,11 +44,6 @@ ifneq "$(GhcWithSMP)" "YES" includes_CC_OPTS += -DNOSMP endif -# The fptools configure script creates the configuration header file and puts it -# in fptools/mk/config.h. We copy it down to here (without any PACKAGE_FOO -# definitions to avoid clashes), prepending some make variables specifying cpp -# platform variables. - ifneq "$(BINDIST)" "YES" ifeq "$(PORTING_HOST)" "YES" @@ -67,8 +58,24 @@ $(includes_H_CONFIG) : mk/config.h mk/config.mk includes/ghc.mk | $$(dir $$@)/. @echo "Creating $@..." @echo "#ifndef __GHCAUTOCONF_H__" >$@ @echo "#define __GHCAUTOCONF_H__" >>$@ -# Turn '#define PACKAGE_FOO "blah"' into '/* #undef PACKAGE_FOO */'. +# +# Copy the contents of mk/config.h, turning '#define PACKAGE_FOO +# "blah"' into '/* #undef PACKAGE_FOO */' to avoid clashes. +# @sed 's,^\([ ]*\)#[ ]*define[ ][ ]*\(PACKAGE_[A-Z]*\)[ ][ ]*".*".*$$,\1/* #undef \2 */,' mk/config.h >> $@ +# +# Tack on some extra config information from the build system +# +ifeq "$(GhcEnableTablesNextToCode) $(GhcUnregisterised)" "YES NO" + @echo >> $@ + @echo "#define TABLES_NEXT_TO_CODE 1" >> $@ +endif +# +ifeq "$(CC_LLVM_BACKEND)" "1" + @echo >> $@ + @echo "#define llvm_CC_FLAVOR 1" >> $@ +endif +# @echo "#endif /* __GHCAUTOCONF_H__ */" >> $@ @echo "Done." @@ -105,10 +112,6 @@ endif @echo "#define $(TargetVendor_CPP)_HOST_VENDOR 1" >> $@ @echo "#define BUILD_VENDOR \"$(HostVendor_CPP)\"" >> $@ @echo "#define HOST_VENDOR \"$(TargetVendor_CPP)\"" >> $@ -ifeq "$(CC_LLVM_BACKEND)" "1" - @echo >> $@ - @echo "#define llvm_CC_FLAVOR 1" >> $@ -endif @echo >> $@ @echo "/* These TARGET macros are for backwards compatibily... DO NOT USE! */" >> $@ @echo "#define TargetPlatform_TYPE $(TargetPlatform_CPP)" >> $@ diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index 10421f0ee9..da71a4bf83 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -77,7 +77,7 @@ struct DEBUG_FLAGS { }; struct COST_CENTRE_FLAGS { - unsigned int doCostCentres; + nat doCostCentres; # define COST_CENTRES_SUMMARY 1 # define COST_CENTRES_VERBOSE 2 /* incl. serial time profile */ # define COST_CENTRES_ALL 3 @@ -88,7 +88,7 @@ struct COST_CENTRE_FLAGS { }; struct PROFILING_FLAGS { - unsigned int doHeapProfile; + nat doHeapProfile; # define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */ # define HEAP_BY_CCS 1 # define HEAP_BY_MOD 2 @@ -160,18 +160,18 @@ struct MISC_FLAGS { struct PAR_FLAGS { nat nNodes; /* number of threads to run simultaneously */ rtsBool migrate; /* migrate threads between capabilities */ - unsigned int maxLocalSparks; + nat maxLocalSparks; rtsBool parGcEnabled; /* enable parallel GC */ - unsigned int parGcGen; /* do parallel GC in this generation + nat parGcGen; /* do parallel GC in this generation * and higher only */ rtsBool parGcLoadBalancingEnabled; /* enable load-balancing in the * parallel GC */ - unsigned int parGcLoadBalancingGen; + nat parGcLoadBalancingGen; /* do load-balancing in this * generation and higher only */ - unsigned int parGcNoSyncWithIdle; + nat parGcNoSyncWithIdle; /* if a Capability has been idle for * this many GCs, do not try to wake * it up when doing a diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h index b34b255770..e4397f2ee3 100644 --- a/includes/rts/storage/InfoTables.h +++ b/includes/rts/storage/InfoTables.h @@ -29,9 +29,9 @@ ------------------------------------------------------------------------- */ #if x86_64_TARGET_ARCH -#define OFFSET_FIELD(n) StgHalfInt n; StgHalfWord __pad_##n; +#define OFFSET_FIELD(n) StgHalfInt n; StgHalfWord __pad_##n #else -#define OFFSET_FIELD(n) StgInt n; +#define OFFSET_FIELD(n) StgInt n #endif /* ----------------------------------------------------------------------------- @@ -196,7 +196,7 @@ typedef union { #ifndef TABLES_NEXT_TO_CODE StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */ #else - OFFSET_FIELD( large_bitmap_offset ); /* offset from info table to large bitmap structure */ + OFFSET_FIELD(large_bitmap_offset); /* offset from info table to large bitmap structure */ #endif StgWord selector_offset; /* used in THUNK_SELECTORs */ @@ -255,12 +255,12 @@ typedef struct StgInfoTable_ { -------------------------------------------------------------------------- */ typedef struct StgFunInfoExtraRev_ { - OFFSET_FIELD ( slow_apply_offset ); /* apply to args on the stack */ + OFFSET_FIELD(slow_apply_offset); /* apply to args on the stack */ union { StgWord bitmap; - OFFSET_FIELD ( bitmap_offset ); /* arg ptr/nonptr bitmap */ + OFFSET_FIELD(bitmap_offset); /* arg ptr/nonptr bitmap */ } b; - OFFSET_FIELD ( srt_offset ); /* pointer to the SRT table */ + OFFSET_FIELD(srt_offset); /* pointer to the SRT table */ StgHalfWord fun_type; /* function type */ StgHalfWord arity; /* function arity */ } StgFunInfoExtraRev; @@ -299,7 +299,7 @@ extern StgWord stg_arg_bitmaps[]; typedef struct { #if defined(TABLES_NEXT_TO_CODE) - OFFSET_FIELD( srt_offset ); /* offset to the SRT table */ + OFFSET_FIELD(srt_offset); /* offset to the SRT table */ StgInfoTable i; #else StgInfoTable i; @@ -321,7 +321,7 @@ typedef struct StgThunkInfoTable_ { StgInfoTable i; #endif #if defined(TABLES_NEXT_TO_CODE) - OFFSET_FIELD( srt_offset ); /* offset to the SRT table */ + OFFSET_FIELD(srt_offset); /* offset to the SRT table */ #else StgSRT *srt; /* pointer to the SRT table */ #endif @@ -340,8 +340,8 @@ typedef struct StgConInfoTable_ { #endif #if defined(TABLES_NEXT_TO_CODE) - OFFSET_FIELD(con_desc) // the name of the data constructor - // as: Package:Module.Name + OFFSET_FIELD(con_desc); // the name of the data constructor + // as: Package:Module.Name #else char *con_desc; #endif diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index da3b07b978..4fed34644c 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -126,6 +126,7 @@ RTS_ENTRY(stg_AP_STACK_NOUPD); RTS_ENTRY(stg_dummy_ret); RTS_ENTRY(stg_raise); RTS_ENTRY(stg_raise_ret); +RTS_ENTRY(stg_atomically); RTS_ENTRY(stg_TVAR_WATCH_QUEUE); RTS_ENTRY(stg_INVARIANT_CHECK_QUEUE); RTS_ENTRY(stg_ATOMIC_INVARIANT); diff --git a/mk/tree.mk b/mk/tree.mk index 8273d6766a..db14cf4127 100644 --- a/mk/tree.mk +++ b/mk/tree.mk @@ -52,7 +52,7 @@ INPLACE_PERL = $(INPLACE)/perl # ################################################################################ -BIN_DIST_INST_SUBDIR = "install dir" +BIN_DIST_INST_SUBDIR = "install dir" BIN_DIST_INST_DIR = bindisttest/$(BIN_DIST_INST_SUBDIR) ################################################################################ @@ -54,7 +54,6 @@ libraries/Cabal - packages/Cabal.git libraries/containers - packages/containers.git git libraries/deepseq - packages/deepseq.git git libraries/directory - packages/directory.git git -libraries/extensible-exceptions - packages/extensible-exceptions.git git libraries/filepath - packages/filepath.git git libraries/ghc-prim - packages/ghc-prim.git git libraries/haskeline - packages/haskeline.git git diff --git a/rts/Capability.c b/rts/Capability.c index 54f9196b99..63e52b0026 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -1,10 +1,10 @@ /* --------------------------------------------------------------------------- * - * (c) The GHC Team, 2003-2006 + * (c) The GHC Team, 2003-2012 * * Capabilities * - * A Capability represent the token required to execute STG code, + * A Capability represents the token required to execute STG code, * and all the state an OS thread/task needs to run Haskell code: * its STG registers, a pointer to its TSO, a nursery etc. During * STG execution, a pointer to the capabilitity is kept in a @@ -273,6 +273,7 @@ initCapability( Capability *cap, nat i ) cap->transaction_tokens = 0; cap->context_switch = 0; cap->pinned_object_block = NULL; + cap->pinned_object_blocks = NULL; #ifdef PROFILING cap->r.rCCCS = CCS_SYSTEM; @@ -476,7 +477,7 @@ releaseCapability_ (Capability* cap, // ThreadBlocked, but the thread may be back on the run queue // by now. task = cap->run_queue_hd->bound->task; - giveCapabilityToTask(cap,task); + giveCapabilityToTask(cap, task); return; } @@ -499,7 +500,7 @@ releaseCapability_ (Capability* cap, !emptyRunQueue(cap) || !emptyInbox(cap) || (!cap->disabled && !emptySparkPoolCap(cap)) || globalWorkToDo()) { if (cap->spare_workers) { - giveCapabilityToTask(cap,cap->spare_workers); + giveCapabilityToTask(cap, cap->spare_workers); // The worker Task pops itself from the queue; return; } @@ -663,7 +664,7 @@ waitForReturnCapability (Capability **pCap, Task *task) cap->r.rCCCS = CCS_SYSTEM; #endif - ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task); + ASSERT_FULL_CAPABILITY_INVARIANTS(cap, task); debugTrace(DEBUG_sched, "resuming capability %d", cap->no); diff --git a/rts/Capability.h b/rts/Capability.h index 2ae2fcf6d7..64273c758b 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -76,6 +76,8 @@ struct Capability_ { // block for allocating pinned objects into bdescr *pinned_object_block; + // full pinned object blocks allocated since the last GC + bdescr *pinned_object_blocks; // Context switch flag. When non-zero, this means: stop running // Haskell code, and switch threads. @@ -331,7 +333,7 @@ void traverseSparkQueues (evac_fn evac, void *user); #ifdef THREADED_RTS -INLINE_HEADER rtsBool emptyInbox(Capability *cap);; +INLINE_HEADER rtsBool emptyInbox(Capability *cap); #endif // THREADED_RTS diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index cb75af01d8..74545af149 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -102,7 +102,7 @@ import LeaveCriticalSection; } else { \ jump %ENTRY_CODE(Sp(0)); \ } \ - } else { \ + } else { \ R1 = HeapOverflow; \ goto sched; \ } \ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 7811af1966..4cb3b8d85c 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -932,6 +932,16 @@ stg_atomicallyzh jump stg_ap_v_fast; } +// A closure representing "atomically x". This is used when a thread +// inside a transaction receives an asynchronous exception; see #5866. +// It is somewhat similar to the stg_raise closure. +// +INFO_TABLE(stg_atomically,1,0,THUNK_1_0,"atomically","atomically") +{ + R1 = StgThunk_payload(R1,0); + jump stg_atomicallyzh; +} + stg_catchSTMzh { diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index 7b7fef1f8c..c14b4112bd 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -957,19 +957,64 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, tso->what_next = ThreadRunGHC; goto done; } - // Not stop_at_atomically... fall through and abort the - // transaction. - - case CATCH_STM_FRAME: + else + { + // Freezing an STM transaction. Just aborting the + // transaction would be wrong; this is what we used to + // do, and it goes wrong if the ATOMICALLY_FRAME ever + // gets back onto the stack again, which it will do if + // the transaction is inside unsafePerformIO or + // unsafeInterleaveIO and hence inside an UPDATE_FRAME. + // + // So we want to make it so that if the enclosing + // computation is resumed, we will re-execute the + // transaction. We therefore: + // + // 1. abort the current transaction + // 3. replace the stack up to and including the + // atomically frame with a closure representing + // a call to "atomically x", where x is the code + // of the transaction. + // 4. continue stripping the stack + // + StgTRecHeader *trec = tso->trec; + StgTRecHeader *outer = trec->enclosing_trec; + + StgThunk *atomically; + StgAtomicallyFrame *af = (StgAtomicallyFrame*)frame; + + debugTraceCap(DEBUG_stm, cap, + "raiseAsync: freezing atomically frame") + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); + tso->trec = outer; + + atomically = (StgThunk*)allocate(cap,sizeofW(StgThunk)+1); + TICK_ALLOC_SE_THK(1,0); + SET_HDR(atomically,&stg_atomically_info,af->header.prof.ccs); + atomically->payload[0] = af->code; + + // discard stack up to and including the ATOMICALLY_FRAME + frame += sizeofW(StgAtomicallyFrame); + sp = frame - 1; + + // replace the ATOMICALLY_FRAME with call to atomically# + sp[0] = (W_)atomically; + continue; + } + + case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: - // IF we find an ATOMICALLY_FRAME then we abort the - // current transaction and propagate the exception. In - // this case (unlike ordinary exceptions) we do not care + // CATCH frames within an atomically block: abort the + // inner transaction and continue. Eventually we will + // hit the outer transaction that will get frozen (see + // above). + // + // In this case (unlike ordinary exceptions) we do not care // whether the transaction is valid or not because its // possible validity cannot have caused the exception // and will not be visible after the abort. - - { + { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; debugTraceCap(DEBUG_stm, cap, @@ -978,8 +1023,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, stmFreeAbortedTRec(cap, trec); tso -> trec = outer; break; - }; - + }; + default: break; } diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 421e81ef07..5afaf4914b 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -361,8 +361,8 @@ usage_text[] = { "", #endif /* DEBUG */ #if defined(THREADED_RTS) && !defined(NOSMP) -" -N<n> Use <n> processors (default: 1)", -" -N Determine the number of processors to use automatically", +" -N[<n>] Use <n> processors (default: 1, -N alone determines", +" the number of processors to use automatically)", " -qg[<n>] Use parallel GC only for generations >= <n>", " (default: 0, -qg alone turns off parallel GC)", " -qb[<n>] Use load-balancing in the parallel GC only for generations >= <n>", diff --git a/rts/RtsMain.c b/rts/RtsMain.c index 2084435f16..e89445db25 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -62,8 +62,7 @@ static void real_main(void) Capability *cap = rts_lock(); rts_evalLazyIO(&cap,progmain_closure, NULL); status = rts_getSchedStatus(cap); - taskTimeStamp(myTask()); - rts_unlock(cap); + rts_unlock(cap); } /* check the status of the entire Haskell computation */ diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index c63f85ee82..4b9f6ba115 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -142,7 +142,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) /* Parse the flags, separating the RTS flags from the programs args */ if (argc != NULL && argv != NULL) { - setFullProgArgv(*argc,*argv); + setFullProgArgv(*argc,*argv); setupRtsFlags(argc, *argv, rts_config.rts_opts_enabled, rts_config.rts_opts); } diff --git a/rts/Schedule.c b/rts/Schedule.c index ce10852adb..e17116bc07 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -128,7 +128,7 @@ static nat n_failed_trygrab_idles = 0, n_idle_caps = 0; static Capability *schedule (Capability *initialCapability, Task *task); // -// These function all encapsulate parts of the scheduler loop, and are +// These functions all encapsulate parts of the scheduler loop, and are // abstracted only to make the structure and control flow of the // scheduler clearer. // diff --git a/rts/Stats.c b/rts/Stats.c index 83c43f0bdd..2c7c35d533 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -287,18 +287,29 @@ stat_startGC (gc_thread *gct) } void -stat_gcWorkerThreadStart (gc_thread *gct) +stat_gcWorkerThreadStart (gc_thread *gct STG_UNUSED) { +#if 0 + /* + * We dont' collect per-thread GC stats any more, but this code + * could be used to do that if we want to in the future: + */ if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) { getProcessTimes(&gct->gc_start_cpu, &gct->gc_start_elapsed); gct->gc_start_thread_cpu = getThreadCPUTime(); } +#endif } void -stat_gcWorkerThreadDone (gc_thread *gct) +stat_gcWorkerThreadDone (gc_thread *gct STG_UNUSED) { +#if 0 + /* + * We dont' collect per-thread GC stats any more, but this code + * could be used to do that if we want to in the future: + */ Time thread_cpu, elapsed, gc_cpu, gc_elapsed; if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) @@ -311,6 +322,7 @@ stat_gcWorkerThreadDone (gc_thread *gct) taskDoneGC(gct->cap->running_task, gc_cpu, gc_elapsed); } +#endif } /* ----------------------------------------------------------------------------- @@ -326,17 +338,13 @@ stat_endGC (gc_thread *gct, RtsFlags.ProfFlags.doHeapProfile) // heap profiling needs GC_tot_time { - Time cpu, elapsed, thread_gc_cpu, gc_cpu, gc_elapsed; + Time cpu, elapsed, gc_cpu, gc_elapsed; getProcessTimes(&cpu, &elapsed); gc_elapsed = elapsed - gct->gc_start_elapsed; - thread_gc_cpu = getThreadCPUTime() - gct->gc_start_thread_cpu; - gc_cpu = cpu - gct->gc_start_cpu; - taskDoneGC(gct->cap->running_task, thread_gc_cpu, gc_elapsed); - if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) { nat faults = getPageFaults(); @@ -629,22 +637,10 @@ stat_exit(int alloc) statsPrintf("\n"); #if defined(THREADED_RTS) - { - nat i; - Task *task; - statsPrintf(" MUT time (elapsed) GC time (elapsed)\n"); - for (i = 0, task = all_tasks; - task != NULL; - i++, task = task->all_link) { - statsPrintf(" Task %2d %-8s : %6.2fs (%6.2fs) %6.2fs (%6.2fs)\n", - i, - (task->worker) ? "(worker)" : "(bound)", - TimeToSecondsDbl(task->mut_time), - TimeToSecondsDbl(task->mut_etime), - TimeToSecondsDbl(task->gc_time), - TimeToSecondsDbl(task->gc_etime)); - } - } + statsPrintf(" TASKS: %d (%d bound, %d peak workers (%d total), using -N%d)\n", + taskCount, taskCount - workerCount, + peakWorkerCount, workerCount, + n_capabilities); statsPrintf("\n"); diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 17aefb6c88..3654b3336a 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -632,7 +632,7 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { /* * save callee-saves registers on behalf of the STG code. */ - "stmfd sp!, {r4-r11, fp, ip, lr}\n\t" + "stmfd sp!, {r4-r10, fp, ip, lr}\n\t" #if !defined(arm_HOST_ARCH_PRE_ARMv6) "vstmdb sp!, {d8-d11}\n\t" #endif @@ -669,10 +669,24 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { #if !defined(arm_HOST_ARCH_PRE_ARMv6) "vldmia sp!, {d8-d11}\n\t" #endif - "ldmfd sp!, {r4-r11, fp, ip, lr}\n\t" + "ldmfd sp!, {r4-r10, fp, ip, lr}\n\t" : "=r" (r) : "r" (f), "r" (basereg), "i" (RESERVED_C_STACK_BYTES) - : "%r4", "%r5", "%r6", "%r8", "%r9", "%r10", "%r11", "%fp", "%ip", "%lr" +#if !defined(__thumb__) + /* In ARM mode, r11/fp is frame-pointer and so we cannot mark + it as clobbered. If we do so, GCC complains with error. */ + : "%r4", "%r5", "%r6", "%r7", "%r8", "%r9", "%r10", "%ip", "%lr" +#else + /* In Thumb mode r7 is frame-pointer and so we cannot mark it + as clobbered. On the other hand we mark as clobbered also + those regs not used in Thumb mode. Hard to judge if this is + needed, but certainly Haskell code is using them for + placing GHC's virtual registers there. See + includes/stg/MachRegs.h Please note that Haskell code is + compiled by GHC/LLVM into ARM code (not Thumb!), at least + as of February 2012 */ + : "%r4", "%r5", "%r6", "%r8", "%r9", "%r10", "%fp", "%ip", "%lr" +#endif ); return r; } diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm index f8940c4196..4aace82deb 100644 --- a/rts/StgStartup.cmm +++ b/rts/StgStartup.cmm @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1998-2004 + * (c) The GHC Team, 1998-2012 * * Code for starting, stopping and restarting threads. * @@ -34,7 +34,7 @@ Returning from the STG world. -------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_stop_thread, STOP_FRAME, +INFO_TABLE_RET(stg_stop_thread, STOP_FRAME, #if defined(PROFILING) W_ unused, W_ unused @@ -101,7 +101,7 @@ stg_returnToSched jump StgReturn; } -// A variant of stg_returntToSched that doesn't call threadPaused() on the +// A variant of stg_returnToSched that doesn't call threadPaused() on the // current thread. This is used for switching from compiled execution to the // interpreter, where calling threadPaused() on every switch would be too // expensive. @@ -138,12 +138,12 @@ stg_threadFinished the int/char/whatever using the various get{Ty} functions provided by the RTS API. - forceIO takes care of this, performing the IO action and entering the - results that comes back. + stg_forceIO takes care of this, performing the IO action and entering + the results that comes back. ------------------------------------------------------------------------- */ -INFO_TABLE_RET( stg_forceIO, RET_SMALL) +INFO_TABLE_RET(stg_forceIO, RET_SMALL) { Sp_adj(1); diff --git a/rts/Task.c b/rts/Task.c index 36dd0a94b9..f4a37bf6ff 100644 --- a/rts/Task.c +++ b/rts/Task.c @@ -26,7 +26,12 @@ // Task lists and global counters. // Locks required: all_tasks_mutex. Task *all_tasks = NULL; -static nat taskCount; + +nat taskCount; +nat workerCount; +nat currentWorkerCount; +nat peakWorkerCount; + static int tasksInitialized = 0; static void freeTask (Task *task); @@ -64,8 +69,11 @@ void initTaskManager (void) { if (!tasksInitialized) { - taskCount = 0; - tasksInitialized = 1; + taskCount = 0; + workerCount = 0; + currentWorkerCount = 0; + peakWorkerCount = 0; + tasksInitialized = 1; #if defined(THREADED_RTS) #if !defined(MYTASK_USE_TLV) newThreadLocalKey(¤tTaskKey); @@ -87,7 +95,7 @@ freeTaskManager (void) ACQUIRE_LOCK(&all_tasks_mutex); for (task = all_tasks; task != NULL; task = next) { - next = task->all_link; + next = task->all_next; if (task->stopped) { freeTask(task); } else { @@ -164,9 +172,6 @@ freeTask (Task *task) static Task* newTask (rtsBool worker) { -#if defined(THREADED_RTS) - Time currentElapsedTime, currentUserTime; -#endif Task *task; #define ROUND_TO_CACHE_LINE(x) ((((x)+63) / 64) * 64) @@ -186,26 +191,25 @@ newTask (rtsBool worker) task->wakeup = rtsFalse; #endif -#if defined(THREADED_RTS) - currentUserTime = getThreadCPUTime(); - currentElapsedTime = getProcessElapsedTime(); - task->mut_time = 0; - task->mut_etime = 0; - task->gc_time = 0; - task->gc_etime = 0; - task->muttimestart = currentUserTime; - task->elapsedtimestart = currentElapsedTime; -#endif - task->next = NULL; ACQUIRE_LOCK(&all_tasks_mutex); - task->all_link = all_tasks; + task->all_prev = NULL; + task->all_next = all_tasks; + if (all_tasks != NULL) { + all_tasks->all_prev = task; + } all_tasks = task; taskCount++; - + if (worker) { + workerCount++; + currentWorkerCount++; + if (currentWorkerCount > peakWorkerCount) { + peakWorkerCount = currentWorkerCount; + } + } RELEASE_LOCK(&all_tasks_mutex); return task; @@ -314,14 +318,15 @@ discardTasksExcept (Task *keep) // Wipe the task list, except the current Task. ACQUIRE_LOCK(&all_tasks_mutex); for (task = all_tasks; task != NULL; task=next) { - next = task->all_link; + next = task->all_next; if (task != keep) { debugTrace(DEBUG_sched, "discarding task %ld", (long)TASK_ID(task)); freeTask(task); } } all_tasks = keep; - keep->all_link = NULL; + keep->all_next = NULL; + keep->all_prev = NULL; RELEASE_LOCK(&all_tasks_mutex); } @@ -337,7 +342,7 @@ void updateCapabilityRefs (void) ACQUIRE_LOCK(&all_tasks_mutex); - for (task = all_tasks; task != NULL; task=task->all_link) { + for (task = all_tasks; task != NULL; task=task->all_next) { if (task->cap != NULL) { task->cap = &capabilities[task->cap->no]; } @@ -353,34 +358,6 @@ void updateCapabilityRefs (void) } -void -taskTimeStamp (Task *task USED_IF_THREADS) -{ -#if defined(THREADED_RTS) - Time currentElapsedTime, currentUserTime; - - currentUserTime = getThreadCPUTime(); - currentElapsedTime = getProcessElapsedTime(); - - task->mut_time = - currentUserTime - task->muttimestart - task->gc_time; - task->mut_etime = - currentElapsedTime - task->elapsedtimestart - task->gc_etime; - - if (task->gc_time < 0) { task->gc_time = 0; } - if (task->gc_etime < 0) { task->gc_etime = 0; } - if (task->mut_time < 0) { task->mut_time = 0; } - if (task->mut_etime < 0) { task->mut_etime = 0; } -#endif -} - -void -taskDoneGC (Task *task, Time cpu_time, Time elapsed_time) -{ - task->gc_time += cpu_time; - task->gc_etime += elapsed_time; -} - #if defined(THREADED_RTS) void @@ -391,9 +368,22 @@ workerTaskStop (Task *task) ASSERT(task->id == id); ASSERT(myTask() == task); - task->cap = NULL; - taskTimeStamp(task); - task->stopped = rtsTrue; + ACQUIRE_LOCK(&all_tasks_mutex); + + if (task->all_prev) { + task->all_prev->all_next = task->all_next; + } else { + all_tasks = task->all_next; + } + if (task->all_next) { + task->all_next->all_prev = task->all_prev; + } + + currentWorkerCount--; + + RELEASE_LOCK(&all_tasks_mutex); + + freeTask(task); } #endif @@ -491,7 +481,7 @@ void printAllTasks(void) { Task *task; - for (task = all_tasks; task != NULL; task = task->all_link) { + for (task = all_tasks; task != NULL; task = task->all_next) { debugBelch("task %p is %s, ", taskId(task), task->stopped ? "stopped" : "alive"); if (!task->stopped) { if (task->cap) { diff --git a/rts/Task.h b/rts/Task.h index 59a316bd81..ab47a07fc3 100644 --- a/rts/Task.h +++ b/rts/Task.h @@ -143,25 +143,13 @@ typedef struct Task_ { // So that we can detect when a finalizer illegally calls back into Haskell rtsBool running_finalizers; - // Stats that we collect about this task - // ToDo: we probably want to put this in a separate TaskStats - // structure, so we can share it between multiple Tasks. We don't - // really want separate stats for each call in a nested chain of - // foreign->haskell->foreign->haskell calls, but we'll get a - // separate Task for each of the haskell calls. - Time elapsedtimestart; - Time muttimestart; - Time mut_time; - Time mut_etime; - Time gc_time; - Time gc_etime; - // Links tasks on the returning_tasks queue of a Capability, and // on spare_workers. struct Task_ *next; // Links tasks on the all_tasks list - struct Task_ *all_link; + struct Task_ *all_next; + struct Task_ *all_prev; } Task; @@ -201,15 +189,6 @@ void boundTaskExiting (Task *task); void workerTaskStop (Task *task); #endif -// Record the time spent in this Task. -// This is called by workerTaskStop() but not by boundTaskExiting(), -// because it would impose an extra overhead on call-in. -// -void taskTimeStamp (Task *task); - -// The current Task has finished a GC, record the amount of time spent. -void taskDoneGC (Task *task, Time cpu_time, Time elapsed_time); - // Put the task back on the free list, mark it stopped. Used by // forkProcess(). // @@ -240,6 +219,11 @@ void interruptWorkerTask (Task *task); // void updateCapabilityRefs (void); +// For stats +extern nat taskCount; +extern nat workerCount; +extern nat peakWorkerCount; + // ----------------------------------------------------------------------------- // INLINE functions... private from here on down: diff --git a/rts/posix/Itimer.c b/rts/posix/Itimer.c index d928147af8..13ba345b03 100644 --- a/rts/posix/Itimer.c +++ b/rts/posix/Itimer.c @@ -126,7 +126,7 @@ initTicker (Time interval, TickProc handle_tick) clockid_t clock; // Keep programs like valgrind happy - memset(&ev, 0, sizeof(ev)); + memset(&ev, 0, sizeof(ev)); ev.sigev_notify = SIGEV_SIGNAL; ev.sigev_signo = ITIMER_SIGNAL; diff --git a/rts/posix/OSThreads.c b/rts/posix/OSThreads.c index b1be93d04b..c29454809f 100644 --- a/rts/posix/OSThreads.c +++ b/rts/posix/OSThreads.c @@ -198,7 +198,6 @@ forkOS_createThreadWrapper ( void * entry ) Capability *cap; cap = rts_lock(); rts_evalStableIO(&cap, (HsStablePtr) entry, NULL); - taskTimeStamp(myTask()); rts_unlock(cap); return NULL; } diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 4f71026dfa..987f78b497 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -979,7 +979,7 @@ compact(StgClosure *static_objects) { Task *task; InCall *incall; - for (task = all_tasks; task != NULL; task = task->all_link) { + for (task = all_tasks; task != NULL; task = task->all_next) { for (incall = task->incall; incall != NULL; incall = incall->prev_stack) { if (incall->tso) { diff --git a/rts/sm/GC.c b/rts/sm/GC.c index aeadf6f42f..86231948c1 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -150,6 +150,7 @@ static StgWord dec_running (void); static void wakeup_gc_threads (nat me); static void shutdown_gc_threads (nat me); static void collect_gct_blocks (void); +static lnat collect_pinned_object_blocks (void); #if 0 && defined(DEBUG) static void gcCAFs (void); @@ -285,6 +286,10 @@ GarbageCollect (rtsBool force_major_gc, // check sanity *before* GC IF_DEBUG(sanity, checkSanity(rtsFalse /* before GC */, major_gc)); + // gather blocks allocated using allocatePinned() from each capability + // and put them on the g0->large_object list. + collect_pinned_object_blocks(); + // Initialise all the generations/steps that we're collecting. for (g = 0; g <= N; g++) { prepare_collected_gen(&generations[g]); @@ -1422,6 +1427,43 @@ collect_gct_blocks (void) } /* ----------------------------------------------------------------------------- + During mutation, any blocks that are filled by allocatePinned() are + stashed on the local pinned_object_blocks list, to avoid needing to + take a global lock. Here we collect those blocks from the + cap->pinned_object_blocks lists and put them on the + main g0->large_object list. + + Returns: the number of words allocated this way, for stats + purposes. + -------------------------------------------------------------------------- */ + +static lnat +collect_pinned_object_blocks (void) +{ + nat n; + bdescr *bd, *prev; + lnat allocated = 0; + + for (n = 0; n < n_capabilities; n++) { + prev = NULL; + for (bd = capabilities[n].pinned_object_blocks; bd != NULL; bd = bd->link) { + allocated += bd->free - bd->start; + prev = bd; + } + if (prev != NULL) { + prev->link = g0->large_objects; + if (g0->large_objects != NULL) { + g0->large_objects->u.back = prev; + } + g0->large_objects = capabilities[n].pinned_object_blocks; + capabilities[n].pinned_object_blocks = 0; + } + } + + return allocated; +} + +/* ----------------------------------------------------------------------------- Initialise a gc_thread before GC -------------------------------------------------------------------------- */ diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index b6c5926ab8..78ecc96e0a 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -869,7 +869,7 @@ memInventory (rtsBool show) gen_blocks[g] += countBlocks(gc_threads[i]->gens[g].part_list); gen_blocks[g] += countBlocks(gc_threads[i]->gens[g].scavd_list); gen_blocks[g] += countBlocks(gc_threads[i]->gens[g].todo_bd); - } + } gen_blocks[g] += genBlocks(&generations[g]); } @@ -880,6 +880,7 @@ memInventory (rtsBool show) if (capabilities[i].pinned_object_block != NULL) { nursery_blocks += capabilities[i].pinned_object_block->blocks; } + nursery_blocks += countBlocks(capabilities[i].pinned_object_blocks); } retainer_blocks = 0; diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 012ba514db..0f5587a6ba 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1998-2008 + * (c) The GHC Team, 1998-2012 * * Storage manager front end * @@ -24,7 +24,7 @@ #include "Arena.h" #include "Capability.h" #include "Schedule.h" -#include "RetainerProfile.h" // for counting memory blocks (memInventory) +#include "RetainerProfile.h" // for counting memory blocks (memInventory) #include "OSMem.h" #include "Trace.h" #include "GC.h" @@ -46,8 +46,8 @@ nat large_alloc_lim; /* GC if n_large_blocks in any nursery bdescr *exec_block; -generation *generations = NULL; /* all the generations */ -generation *g0 = NULL; /* generation 0, for convenience */ +generation *generations = NULL; /* all the generations */ +generation *g0 = NULL; /* generation 0, for convenience */ generation *oldest_gen = NULL; /* oldest generation, for convenience */ nursery *nurseries = NULL; /* array of nurseries, size == n_capabilities */ @@ -92,7 +92,7 @@ initGeneration (generation *gen, int g) } void -initStorage( void ) +initStorage (void) { nat g; @@ -114,7 +114,7 @@ initStorage( void ) if (RtsFlags.GcFlags.maxHeapSize != 0 && RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { - RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; } if (RtsFlags.GcFlags.maxHeapSize != 0 && @@ -134,8 +134,8 @@ initStorage( void ) /* allocate generation info array */ generations = (generation *)stgMallocBytes(RtsFlags.GcFlags.generations - * sizeof(struct generation_), - "initStorage: gens"); + * sizeof(struct generation_), + "initStorage: gens"); /* Initialise all generations */ for(g = 0; g < RtsFlags.GcFlags.generations; g++) { @@ -155,9 +155,9 @@ initStorage( void ) /* The oldest generation has one step. */ if (RtsFlags.GcFlags.compact || RtsFlags.GcFlags.sweep) { if (RtsFlags.GcFlags.generations == 1) { - errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled"); + errorBelch("WARNING: compact/sweep is incompatible with -G1; disabled"); } else { - oldest_gen->mark = 1; + oldest_gen->mark = 1; if (RtsFlags.GcFlags.compact) oldest_gen->compact = 1; } @@ -197,7 +197,7 @@ void storageAddCapabilities (nat from, nat to) "storageAddCapabilities"); } else { nurseries = stgMallocBytes(to * sizeof(struct nursery_), - "storageAddCapabilities"); + "storageAddCapabilities"); } // we've moved the nurseries, so we have to update the rNursery @@ -271,7 +271,7 @@ freeStorage (rtsBool free_heap) - it puts the CAF on the oldest generation's mutable list. This is so that we treat the CAF as a root when collecting - younger generations. + younger generations. ------------------ Note [atomic CAF entry] @@ -470,7 +470,7 @@ assignNurseriesToCapabilities (nat from, nat to) for (i = from; i < to; i++) { capabilities[i].r.rCurrentNursery = nurseries[i].blocks; - capabilities[i].r.rCurrentAlloc = NULL; + capabilities[i].r.rCurrentAlloc = NULL; } } @@ -482,7 +482,7 @@ allocNurseries (nat from, nat to) for (i = from; i < to; i++) { nurseries[i].blocks = allocNursery(NULL, RtsFlags.GcFlags.minAllocAreaSize); - nurseries[i].n_blocks = + nurseries[i].n_blocks = RtsFlags.GcFlags.minAllocAreaSize; } assignNurseriesToCapabilities(from, to); @@ -496,13 +496,13 @@ clearNurseries (void) bdescr *bd; for (i = 0; i < n_capabilities; i++) { - for (bd = nurseries[i].blocks; bd; bd = bd->link) { + for (bd = nurseries[i].blocks; bd; bd = bd->link) { allocated += (lnat)(bd->free - bd->start); bd->free = bd->start; - ASSERT(bd->gen_no == 0); - ASSERT(bd->gen == g0); - IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE)); - } + ASSERT(bd->gen_no == 0); + ASSERT(bd->gen == g0); + IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE)); + } } return allocated; @@ -521,13 +521,13 @@ countNurseryBlocks (void) lnat blocks = 0; for (i = 0; i < n_capabilities; i++) { - blocks += nurseries[i].n_blocks; + blocks += nurseries[i].n_blocks; } return blocks; } static void -resizeNursery ( nursery *nursery, nat blocks ) +resizeNursery (nursery *nursery, nat blocks) { bdescr *bd; nat nursery_blocks; @@ -537,28 +537,28 @@ resizeNursery ( nursery *nursery, nat blocks ) if (nursery_blocks < blocks) { debugTrace(DEBUG_gc, "increasing size of nursery to %d blocks", - blocks); + blocks); nursery->blocks = allocNursery(nursery->blocks, blocks-nursery_blocks); } else { bdescr *next_bd; debugTrace(DEBUG_gc, "decreasing size of nursery to %d blocks", - blocks); + blocks); bd = nursery->blocks; while (nursery_blocks > blocks) { - next_bd = bd->link; - next_bd->u.back = NULL; - nursery_blocks -= bd->blocks; // might be a large block - freeGroup(bd); - bd = next_bd; + next_bd = bd->link; + next_bd->u.back = NULL; + nursery_blocks -= bd->blocks; // might be a large block + freeGroup(bd); + bd = next_bd; } nursery->blocks = bd; // might have gone just under, by freeing a large block, so make // up the difference. if (nursery_blocks < blocks) { - nursery->blocks = allocNursery(nursery->blocks, blocks-nursery_blocks); + nursery->blocks = allocNursery(nursery->blocks, blocks-nursery_blocks); } } @@ -574,7 +574,7 @@ resizeNurseriesFixed (nat blocks) { nat i; for (i = 0; i < n_capabilities; i++) { - resizeNursery(&nurseries[i], blocks); + resizeNursery(&nurseries[i], blocks); } } @@ -628,7 +628,7 @@ allocate (Capability *cap, lnat n) CCS_ALLOC(cap->r.rCCCS,n); if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) { - lnat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE; + lnat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE; // Attempting to allocate an object larger than maxHeapSize // should definitely be disallowed. (bug #1791) @@ -644,19 +644,19 @@ allocate (Capability *cap, lnat n) // Allocating the memory would be bad, because the user // has requested that we not exceed maxHeapSize, so we // just exit. - stg_exit(EXIT_HEAPOVERFLOW); + stg_exit(EXIT_HEAPOVERFLOW); } ACQUIRE_SM_LOCK - bd = allocGroup(req_blocks); - dbl_link_onto(bd, &g0->large_objects); - g0->n_large_blocks += bd->blocks; // might be larger than req_blocks + bd = allocGroup(req_blocks); + dbl_link_onto(bd, &g0->large_objects); + g0->n_large_blocks += bd->blocks; // might be larger than req_blocks g0->n_new_large_words += n; RELEASE_SM_LOCK; initBdescr(bd, g0, g0); - bd->flags = BF_LARGE; - bd->free = bd->start + n; - return bd->start; + bd->flags = BF_LARGE; + bd->free = bd->start + n; + return bd->start; } /* small allocation (<LARGE_OBJECT_THRESHOLD) */ @@ -733,7 +733,7 @@ allocatePinned (Capability *cap, lnat n) // If the request is for a large object, then allocate() // will give us a pinned object anyway. if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) { - p = allocate(cap, n); + p = allocate(cap, n); Bdescr(p)->flags |= BF_PINNED; return p; } @@ -744,8 +744,54 @@ allocatePinned (Capability *cap, lnat n) bd = cap->pinned_object_block; // If we don't have a block of pinned objects yet, or the current - // one isn't large enough to hold the new object, allocate a new one. + // one isn't large enough to hold the new object, get a new one. if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) { + + // stash the old block on cap->pinned_object_blocks. On the + // next GC cycle these objects will be moved to + // g0->large_objects. + if (bd != NULL) { + dbl_link_onto(bd, &cap->pinned_object_blocks); + } + + // We need to find another block. We could just allocate one, + // but that means taking a global lock and we really want to + // avoid that (benchmarks that allocate a lot of pinned + // objects scale really badly if we do this). + // + // So first, we try taking the next block from the nursery, in + // the same way as allocate(), but note that we can only take + // an *empty* block, because we're about to mark it as + // BF_PINNED | BF_LARGE. + bd = cap->r.rCurrentNursery->link; + if (bd == NULL || bd->free != bd->start) { // must be empty! + // The nursery is empty, or the next block is non-empty: + // allocate a fresh block (we can't fail here). + + // XXX in the case when the next nursery block is + // non-empty we aren't exerting any pressure to GC soon, + // so if this case ever happens then we could in theory + // keep allocating for ever without calling the GC. We + // can't bump g0->n_new_large_words because that will be + // counted towards allocation, and we're already counting + // our pinned obects as allocation in + // collect_pinned_object_blocks in the GC. + ACQUIRE_SM_LOCK; + bd = allocBlock(); + RELEASE_SM_LOCK; + initBdescr(bd, g0, g0); + } else { + // we have a block in the nursery: steal it + cap->r.rCurrentNursery->link = bd->link; + if (bd->link != NULL) { + bd->link->u.back = cap->r.rCurrentNursery; + } + cap->r.rNursery->n_blocks--; + } + + cap->pinned_object_block = bd; + bd->flags = BF_PINNED | BF_LARGE | BF_EVACUATED; + // The pinned_object_block remains attached to the capability // until it is full, even if a GC occurs. We want this // behaviour because otherwise the unallocated portion of the @@ -759,17 +805,6 @@ allocatePinned (Capability *cap, lnat n) // the next GC the BF_EVACUATED flag will be cleared, and the // block will be promoted as usual (if anything in it is // live). - ACQUIRE_SM_LOCK; - if (bd != NULL) { - dbl_link_onto(bd, &g0->large_objects); - g0->n_large_blocks++; - g0->n_new_large_words += bd->free - bd->start; - } - cap->pinned_object_block = bd = allocBlock(); - RELEASE_SM_LOCK; - initBdescr(bd, g0, g0); - bd->flags = BF_PINNED | BF_LARGE | BF_EVACUATED; - bd->free = bd->start; } p = bd->free; @@ -792,7 +827,7 @@ dirty_MUT_VAR(StgRegTable *reg, StgClosure *p) { Capability *cap = regTableToCapability(reg); if (p->header.info == &stg_MUT_VAR_CLEAN_info) { - p->header.info = &stg_MUT_VAR_DIRTY_info; + p->header.info = &stg_MUT_VAR_DIRTY_info; recordClosureMutated(cap,p); } } @@ -1060,24 +1095,24 @@ void *allocateExec (nat bytes, void **exec_ret) n = (bytes + sizeof(W_) + 1) / sizeof(W_); if (n+1 > BLOCK_SIZE_W) { - barf("allocateExec: can't handle large objects"); + barf("allocateExec: can't handle large objects"); } if (exec_block == NULL || - exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) { - bdescr *bd; - lnat pagesize = getPageSize(); - bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE)); - debugTrace(DEBUG_gc, "allocate exec block %p", bd->start); - bd->gen_no = 0; - bd->flags = BF_EXEC; - bd->link = exec_block; - if (exec_block != NULL) { - exec_block->u.back = bd; - } - bd->u.back = NULL; - setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue); - exec_block = bd; + exec_block->free + n + 1 > exec_block->start + BLOCK_SIZE_W) { + bdescr *bd; + lnat pagesize = getPageSize(); + bd = allocGroup(stg_max(1, pagesize / BLOCK_SIZE)); + debugTrace(DEBUG_gc, "allocate exec block %p", bd->start); + bd->gen_no = 0; + bd->flags = BF_EXEC; + bd->link = exec_block; + if (exec_block != NULL) { + exec_block->u.back = bd; + } + bd->u.back = NULL; + setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsTrue); + exec_block = bd; } *(exec_block->free) = n; // store the size of this chunk exec_block->gen_no += n; // gen_no stores the number of words allocated @@ -1095,11 +1130,11 @@ void freeExec (void *addr) bdescr *bd = Bdescr((StgPtr)p); if ((bd->flags & BF_EXEC) == 0) { - barf("freeExec: not executable"); + barf("freeExec: not executable"); } if (*(StgPtr)p == 0) { - barf("freeExec: already free?"); + barf("freeExec: already free?"); } ACQUIRE_SM_LOCK; @@ -1128,10 +1163,10 @@ void freeExec (void *addr) #ifdef DEBUG // handy function for use in gdb, because Bdescr() is inlined. -extern bdescr *_bdescr( StgPtr p ); +extern bdescr *_bdescr (StgPtr p); bdescr * -_bdescr( StgPtr p ) +_bdescr (StgPtr p) { return Bdescr(p); } diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index de1b7131e3..dec2c551ee 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -28,7 +28,7 @@ $(call hs-objs,$1,$2,$3) $1_$2_$3_LIB = $1/$2/build/libHS$$($1_PACKAGE)-$$($1_$2_VERSION)$$($3_libsuf) $$($1_PACKAGE)-$($1_$2_VERSION)_$2_$3_LIB = $$($1_$2_$3_LIB) -# hack: the DEPS_LIBS mechanism assumes that the distdirs for packges +# hack: the DEPS_LIBS mechanism assumes that the distdirs for packages # that depend on each other are the same, but that is not the case for # ghc where we use stage1/stage2 rather than dist/dist-install. # Really we should use a consistent scheme for distdirs, but in the diff --git a/rules/cmm-suffix-rules.mk b/rules/cmm-suffix-rules.mk index 6a52dc46bf..8549bce5b0 100644 --- a/rules/cmm-suffix-rules.mk +++ b/rules/cmm-suffix-rules.mk @@ -22,16 +22,16 @@ ifneq "$$(CLEANING)" "YES" ifneq "$$(BootingFromHc)" "YES" -$1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)o : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)o : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)hc : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)hc : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -C $$< -o $$@ -$1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -C $$< -o $$@ # XXX @@ -129,6 +129,29 @@ sub warning { } } +sub gitNewWorkdir { + my $dir = shift; + my $target = shift; + my $target_dir = "$target/$dir"; + my $pwd; + + if ($dir eq '.') { + message "== running git-new-workdir . $target_dir @_"; + } else { + message "== $dir: running git-new-workdir . $target_dir @_"; + $pwd = getcwd(); + chdir($dir); + } + + system ("git-new-workdir", ".", $target_dir, @_) == 0 + or $ignore_failure + or die "git-new-workdir failed: $?"; + + if ($dir ne '.') { + chdir($pwd); + } +} + sub scm { my $dir = shift; my $scm = shift; @@ -343,6 +366,9 @@ sub scmall { elsif ($command =~ /^(?:pul|pull)$/) { scm ($localpath, $scm, "pull", @args); } + elsif ($command =~ /^(?:new-workdir)$/) { + gitNewWorkdir ($localpath, @args); + } elsif ($command =~ /^(?:s|se|sen|send)$/) { if ($scm eq "darcs") { $command = "send"; @@ -511,6 +537,7 @@ any extra arguments to git: grep log new + new-workdir pull push repack diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 14664a8ada..e29301d933 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -611,7 +611,7 @@ readParseDatabase verbosity mb_user_conf use_cache path Right tcache | tcache >= tdir -> do when (verbosity > Normal) $ - putStrLn ("using cache: " ++ cache) + infoLn ("using cache: " ++ cache) pkgs <- myReadBinPackageDB cache let pkgs' = map convertPackageInfoIn pkgs mkPackageDB pkgs' @@ -649,7 +649,7 @@ myReadBinPackageDB filepath = do parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo] parseMultiPackageConf verbosity file = do - when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file) + when (verbosity > Normal) $ infoLn ("reading package database: " ++ file) str <- readUTF8File file let pkgs = map convertPackageInfoIn $ read str Exception.evaluate pkgs @@ -658,7 +658,7 @@ parseMultiPackageConf verbosity file = do parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do - when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file) + when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) readUTF8File file >>= fmap fst . parsePackageInfo cachefilename :: FilePath @@ -767,13 +767,13 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f case input of "-" -> do when (verbosity >= Normal) $ - putStr "Reading package info from stdin ... " + info "Reading package info from stdin ... " -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdin utf8 getContents f -> do when (verbosity >= Normal) $ - putStr ("Reading package info from " ++ show f ++ " ... ") + info ("Reading package info from " ++ show f ++ " ... ") readUTF8File f expanded <- if expand_env_vars then expandEnvVars s force @@ -781,7 +781,7 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f (pkg, ws) <- parsePackageInfo expanded when (verbosity >= Normal) $ - putStrLn "done." + infoLn "done." -- report any warnings from the parse phase _ <- reportValidateErrors [] ws @@ -795,7 +795,7 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f let truncated_stack = dropWhile ((/= to_modify).location) db_stack -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. - validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force + validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force let removes = [ RemovePackage p | p <- packages db_to_operate_on, @@ -850,11 +850,11 @@ changeDBDir verbosity cmds db = do where do_cmd (RemovePackage p) = do let file = location db </> display (installedPackageId p) <.> "conf" - when (verbosity > Normal) $ putStrLn ("removing " ++ file) + when (verbosity > Normal) $ infoLn ("removing " ++ file) removeFileSafe file do_cmd (AddPackage p) = do let file = location db </> display (installedPackageId p) <.> "conf" - when (verbosity > Normal) $ putStrLn ("writing " ++ file) + when (verbosity > Normal) $ infoLn ("writing " ++ file) writeFileUtf8Atomic file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -863,7 +863,7 @@ updateDBCache :: Verbosity -> PackageDB -> IO () updateDBCache verbosity db = do let filename = location db </> cachefilename when (verbosity > Normal) $ - putStrLn ("writing cache " ++ filename) + infoLn ("writing cache " ++ filename) writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) `catchIO` \e -> if isPermissionError e @@ -1144,7 +1144,7 @@ describeField verbosity my_flags pkgarg fields expand_pkgroot = do Nothing -> die ("unknown field: " ++ f) Just fn -> do fns <- toFields fs return (fn:fns) - selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns + selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns toField :: String -> Maybe (InstalledPackageInfo -> String) -- backwards compatibility: @@ -1181,7 +1181,7 @@ checkConsistency verbosity my_flags = do let pkgs = allPackagesInStack db_stack checkPackage p = do - (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True + (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True if null es then do when (not simple_output) $ do _ <- reportValidateErrors [] ws "" Nothing @@ -1259,7 +1259,7 @@ convertPackageInfoIn writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () writeNewConfig verbosity filename ipis = do when (verbosity >= Normal) $ - hPutStr stdout "Writing new package config file... " + info "Writing new package config file... " createDirectoryIfMissing True $ takeDirectory filename let shown = concat $ intersperse ",\n " $ map (show . convertPackageInfoOut) ipis @@ -1270,7 +1270,7 @@ writeNewConfig verbosity filename ipis = do then die (filename ++ ": you don't have permission to modify this file") else ioError e when (verbosity >= Normal) $ - hPutStrLn stdout "done." + infoLn "done." ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs @@ -1321,22 +1321,24 @@ reportValidateErrors es ws prefix mb_force = do err = prefix ++ s validatePackageConfig :: InstalledPackageInfo + -> Verbosity -> PackageDBStack -> Bool -- auto-ghc-libs -> Bool -- update, or check -> Force -> IO () -validatePackageConfig pkg db_stack auto_ghci_libs update force = do - (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update +validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do + (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) when (not ok) $ exitWith (ExitFailure 1) checkPackageConfig :: InstalledPackageInfo + -> Verbosity -> PackageDBStack -> Bool -- auto-ghc-libs -> Bool -- update, or check -> Validate () -checkPackageConfig pkg db_stack auto_ghci_libs update = do +checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do checkInstalledPackageId pkg db_stack update checkPackageId pkg checkDuplicates db_stack pkg update @@ -1349,7 +1351,7 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) checkModules pkg - mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) + mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? -- extra_libraries :: [String], -- c_includes :: [String], @@ -1449,14 +1451,14 @@ checkDuplicateDepends deps where dups = [ p | (p:_:_) <- group (sort deps) ] -checkHSLib :: [String] -> Bool -> String -> Validate () -checkHSLib dirs auto_ghci_libs lib = do +checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate () +checkHSLib verbosity dirs auto_ghci_libs lib = do let batch_lib_file = "lib" ++ lib ++ ".a" m <- liftIO $ doesFileExistOnPath batch_lib_file dirs case m of Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ " on library path") - Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs + Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) doesFileExistOnPath file path = go path @@ -1479,9 +1481,9 @@ checkModules pkg = do when (isNothing m) $ verror ForceFiles ("file " ++ file ++ " is missing") -checkGHCiLib :: String -> String -> String -> Bool -> IO () -checkGHCiLib batch_lib_dir batch_lib_file lib auto_build - | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file +checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO () +checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build + | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file | otherwise = return () where ghci_lib_file = lib <.> "o" @@ -1489,11 +1491,12 @@ checkGHCiLib batch_lib_dir batch_lib_file lib auto_build -- automatically build the GHCi version of a batch lib, -- using ld --whole-archive. -autoBuildGHCiLib :: String -> String -> String -> IO () -autoBuildGHCiLib dir batch_file ghci_file = do +autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO () +autoBuildGHCiLib verbosity dir batch_file ghci_file = do let ghci_lib_file = dir ++ '/':ghci_file batch_lib_file = dir ++ '/':batch_file - hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...") + when (verbosity >= Normal) $ + info ("building GHCi library " ++ ghci_lib_file ++ "...") #if defined(darwin_HOST_OS) r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] #elif defined(mingw32_HOST_OS) @@ -1503,7 +1506,8 @@ autoBuildGHCiLib dir batch_file ghci_file = do r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #endif when (r /= ExitSuccess) $ exitWith r - hPutStrLn stderr (" done.") + when (verbosity >= Normal) $ + infoLn (" done.") -- ----------------------------------------------------------------------------- -- Searching for modules @@ -1582,9 +1586,8 @@ die = dieWith 1 dieWith :: Int -> String -> IO a dieWith ec s = do - hFlush stdout prog <- getProgramName - hPutStrLn stderr (prog ++ ": " ++ s) + reportError (prog ++ ": " ++ s) exitWith (ExitFailure ec) dieOrForceAll :: Force -> String -> IO () @@ -1594,6 +1597,13 @@ dieOrForceAll _other s = dieForcible s warn :: String -> IO () warn = reportError +-- send info messages to stdout +infoLn :: String -> IO () +infoLn = putStrLn + +info :: String -> IO () +info = putStr + ignoreError :: String -> IO () ignoreError s = reportError (s ++ " (ignoring)") diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index b4302cc8e0..11b7c8f26a 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -63,7 +63,6 @@ utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/ -XCPP -XExistentialQuantification -XDeriveDataTypeable \ -ilibraries/Cabal/Cabal \ -ilibraries/filepath \ - -ilibraries/extensible-exceptions \ -ilibraries/hpc \ -ilibraries/binary/src \ -ilibraries/bin-package-db diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index c0e51802a1..ea3300c66a 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -11,7 +11,7 @@ import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) import Panic ( panic ) -import DynFlags ( defaultLogAction ) +import DynFlags ( defaultLogAction, defaultFlushOut ) import Bag import Exception import FastString @@ -102,7 +102,7 @@ main = do then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler defaultLogAction $ + GHC.defaultErrorHandler defaultLogAction defaultFlushOut $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags @@ -112,12 +112,26 @@ if [ $speed != "FAST" ]; then # coverage, and also verify that we can install a package into the # bindist with Cabal. # - bindistdir="bindisttest/install dir" + bindistdir="bindisttest/install dir" + + # This is a hack to make + # HADDOCK_DOCS = NO + # work when validating. + if grep -q "^HADDOCK_DOCS.*=.*NO" mk/validate.mk + then + unset WITH_HADDOCK + DO_HADDOCK=NO + else + WITH_HADDOCK=--with-haddock="$thisdir/$bindistdir/bin/haddock" + DO_HADDOCK=YES + fi + cd libraries/mtl "$thisdir/$bindistdir/bin/ghc" --make Setup - ./Setup configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --with-haddock="$thisdir/$bindistdir/bin/haddock" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir" + + ./Setup configure --with-ghc="$thisdir/$bindistdir/bin/ghc" ${WITH_HADDOCK+"$WITH_HADDOCK"} --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir" ./Setup build --builddir=dist-bindist - ./Setup haddock --builddir=dist-bindist + [ "$DO_HADDOCK" = "YES" ] && ./Setup haddock --builddir=dist-bindist ./Setup install --builddir=dist-bindist ./Setup clean --builddir=dist-bindist rm -f Setup Setup.exe Setup.hi Setup.o |