Super-monster patch implementing the new typechecker -- at last
authorsimonpj@microsoft.com <unknown>
Mon, 13 Sep 2010 09:50:48 +0000 (09:50 +0000)
committersimonpj@microsoft.com <unknown>
Mon, 13 Sep 2010 09:50:48 +0000 (09:50 +0000)
This major patch implements the new OutsideIn constraint solving
algorithm in the typecheker, following our JFP paper "Modular type
inference with local assumptions".

Done with major help from Dimitrios Vytiniotis and Brent Yorgey.

131 files changed:
compiler/HsVersions.h
compiler/basicTypes/Id.lhs
compiler/basicTypes/MkId.lhs
compiler/basicTypes/Var.lhs
compiler/basicTypes/VarEnv.lhs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmCPSZ.hs
compiler/cmm/CmmSpillReload.hs
compiler/cmm/CmmStackLayout.hs
compiler/cmm/ZipCfg.hs
compiler/cmm/ZipCfgCmmRep.hs
compiler/cmm/ZipDataflow.hs
compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CorePrep.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreTidy.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/MkCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/ghc.cabal.in
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/Linker.lhs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsTypes.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceType.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscTypes.lhs
compiler/main/PprTyThing.hs
compiler/main/StaticFlagParser.hs
compiler/main/StaticFlags.hs
compiler/main/TidyPgm.lhs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/nativeGen/X86/Instr.hs
compiler/parser/Parser.y.pp
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/simplCore/FloatIn.lhs
compiler/simplCore/FloatOut.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SetLevels.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Rules.lhs
compiler/specialise/SpecConstr.lhs
compiler/stgSyn/CoreToStg.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcAnnotations.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs [new file with mode: 0644]
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcDefaults.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs [new file with mode: 0644]
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcExpr.lhs-boot
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs [new file with mode: 0644]
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcMatches.lhs-boot
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcSMonad.lhs [new file with mode: 0644]
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSimplify.lhs-old [new file with mode: 0644]
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcSplice.lhs-boot
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyFuns.lhs-old [moved from compiler/typecheck/TcTyFuns.lhs with 99% similarity]
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/typecheck/TcUnify.lhs-boot
compiler/types/Class.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/FunDeps.lhs
compiler/types/InstEnv.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/utils/Bag.lhs
compiler/utils/Digraph.lhs
compiler/utils/Outputable.lhs
compiler/vectorise/VectMonad.hs [new file with mode: 0644]
compiler/vectorise/Vectorise/Monad/InstEnv.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/PData.hs
compiler/vectorise/Vectorise/Type/PRepr.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Utils.hs
new_tc_notes [new file with mode: 0644]

index aa251f4..ad17189 100644 (file)
@@ -56,7 +56,7 @@ name = Util.globalMVar (value);
 #ifdef DEBUG
 #define ASSERT(e)      if (not (e)) then (assertPanic __FILE__ __LINE__) else
 #define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
 #else
 -- We have to actually use all the variables we are given or we may get
 -- unused variable warnings when DEBUG is off.
index fbf6b4a..1efc273 100644 (file)
@@ -30,7 +30,7 @@ module Id (
        mkLocalId, mkLocalIdWithInfo, mkExportedLocalId,
        mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
        mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
-       mkWorkerId, 
+       mkWorkerId, mkWiredInIdName,
 
        -- ** Taking an Id apart
        idName, idType, idUnique, idInfo, idDetails,
@@ -258,6 +258,9 @@ mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
 mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id
 mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc))
 
+mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
+mkWiredInIdName mod fs uniq id
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
 \end{code}
 
 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
index 6d6a835..1984633 100644 (file)
@@ -25,26 +25,22 @@ module MkId (
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
-        unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
-        lazyId, lazyIdKey,
+        unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
+        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
 
-        mkRuntimeErrorApp, mkImpossibleExpr,
-        rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
-        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
-        pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
-
-        unsafeCoerceName
+       -- Re-export error Ids
+       module PrelRules
     ) where
 
 #include "HsVersions.h"
 
 import Rules
 import TysPrim
-import TysWiredIn
 import PrelRules
 import Type
 import Coercion
 import TcType
+import MkCore
 import CoreUtils       ( exprType, mkCoerce )
 import CoreUnfold
 import Literal
@@ -362,7 +358,8 @@ mkDataConIds wrap_name wkr_name data_con
 
     mkCoVarLocals i []     = ([],i)
     mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
+                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) 
+                                                  (fsLit "dc_co")) x
                              in (y:ys,j)
 
     mk_case 
@@ -436,10 +433,12 @@ at the outside.  When dealing with classes it's very convenient to
 recover the original type signature from the class op selector.
 
 \begin{code}
-mkDictSelId :: Bool    -- True <=> don't include the unfolding
-                       -- Little point on imports without -O, because the
-                       -- dictionary itself won't be visible
-           -> Name -> Class -> Id
+mkDictSelId :: Bool         -- True <=> don't include the unfolding
+                            -- Little point on imports without -O, because the
+                            -- dictionary itself won't be visible
+           -> Name          -- Name of one of the *value* selectors 
+                            -- (dictionary superclass or method)
+            -> Class -> Id
 mkDictSelId no_unf name clas
   = mkGlobalId (ClassOpId clas) name sel_ty info
   where
@@ -474,7 +473,7 @@ mkDictSelId no_unf name clas
                                     occNameFS (getOccName name)
                        , ru_fn    = name
                       , ru_nargs = n_ty_args + 1
-                       , ru_try   = dictSelRule index n_ty_args }
+                       , ru_try   = dictSelRule val_index n_ty_args n_eq_args }
 
         -- The strictness signature is of the form U(AAAVAAAA) -> T
         -- where the V depends on which item we are selecting
@@ -485,41 +484,45 @@ mkDictSelId no_unf name clas
             | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
                                      | id <- arg_ids ])
 
-    tycon      = classTyCon clas
-    new_tycon  = isNewTyCon tycon
-    [data_con] = tyConDataCons tycon
-    tyvars     = dataConUnivTyVars data_con
-    arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
-    eq_theta   = dataConEqTheta data_con
-    index      = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name
-    the_arg_id = arg_ids !! index
+    tycon                 = classTyCon clas
+    new_tycon             = isNewTyCon tycon
+    [data_con]            = tyConDataCons tycon
+    tyvars                = dataConUnivTyVars data_con
+    arg_tys               = dataConRepArgTys data_con  -- Includes the dictionary superclasses
+    eq_theta              = dataConEqTheta data_con
+    n_eq_args      = length eq_theta
 
-    pred       = mkClassPred clas (mkTyVarTys tyvars)
-    dict_id    = mkTemplateLocal 1 $ mkPredTy pred
-    (eq_ids,n) = mkCoVarLocals   2 $ mkPredTys eq_theta
-    arg_ids    = mkTemplateLocalsNum n arg_tys
+    -- 'index' is a 0-index into the *value* arguments of the dictionary
+    val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
+    sel_index_prs  = map idName (classAllSelIds clas) `zip` [0..]
 
-    mkCoVarLocals i []     = ([],i)
-    mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
-                             in (y:ys,j)
+    the_arg_id     = arg_ids !! val_index
+    pred                  = mkClassPred clas (mkTyVarTys tyvars)
+    dict_id               = mkTemplateLocal 1 $ mkPredTy pred
+    arg_ids               = mkTemplateLocalsNum 2 arg_tys
+    eq_ids                = map mkWildEvBinder eq_theta
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
                                 [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
 
-dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+dictSelRule :: Int -> Arity -> Arity 
+            -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 -- Oh, very clever
---       op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
---       op_i t1..tk (D t1..tk op1 ... opm) = opi
+--       sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+--       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
--- NB: the data constructor has the same number of type args as the class op
-
-dictSelRule index n_ty_args id_unf args
+-- NB: the data constructor has the same number of type and 
+--     coercion args as the selector
+--
+-- This only works for *value* superclasses
+-- There are no selector functions for equality superclasses
+dictSelRule val_index n_ty_args n_eq_args id_unf args
   | (dict_arg : _) <- drop n_ty_args args
-  , Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg
-  = Just (val_args !! index)
+  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
+  , let val_args = drop n_eq_args con_args
+  = Just (val_args !! val_index)
   | otherwise
   = Nothing
 \end{code}
@@ -644,7 +647,7 @@ mkReboxingAlt us con args rhs
 
     -- Type variable case
     go (arg:args) stricts us 
-      | isTyVar arg
+      | isTyCoVar arg
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')
 
@@ -884,31 +887,12 @@ they can unify with both unlifted and lifted types.  Hence we provide
 another gun with which to shoot yourself in the foot.
 
 \begin{code}
-mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
-mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
-
-unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-lazyIdName, errorName, recSelErrorName, runtimeErrorName :: Name
-irrefutPatErrorName, recConErrorName, patErrorName :: Name
-nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
 unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
 seqName          = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
 realWorldName    = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
 lazyIdName       = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
-
-errorName                = mkWiredInIdName gHC_ERR (fsLit "error")            errorIdKey eRROR_ID
-recSelErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName         = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
-irrefutPatErrorName      = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
-recConErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
-patErrorName             = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
-noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
-                                           noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
-nonExhaustiveGuardsErrorName 
-  = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") 
-                    nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
 \end{code}
 
 \begin{code}
@@ -974,7 +958,7 @@ lazyId = pcMiscPrelId lazyIdName ty info
 
 Note [seqId magic]
 ~~~~~~~~~~~~~~~~~~
-'GHC.Prim.seq' is special in several ways.  
+'GHC.Prim.seq' is special in several ways. 
 
 a) Its second arg can have an unboxed type
       x `seq` (v +# w)
@@ -986,6 +970,8 @@ c) It has quite a bit of desugaring magic.
 
 d) There is some special rule handing: Note [User-defined RULES for seq]
 
+e) See Note [Typing rule for seq] in TcExpr.
+
 Note [User-defined RULES for seq]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Roman found situations where he had
@@ -1071,81 +1057,6 @@ voidArgId       -- :: State# RealWorld
 \end{code}
 
 
-%************************************************************************
-%*                                                                      *
-\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
-%*                                                                      *
-%************************************************************************
-
-GHC randomly injects these into the code.
-
-@patError@ is just a version of @error@ for pattern-matching
-failures.  It knows various ``codes'' which expand to longer
-strings---this saves space!
-
-@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
-well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absentErr@ (rather than a totally random
-crash).
-
-@parError@ is a special version of @error@ which the compiler does
-not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
-templates, but we don't ever expect to generate code for it.
-
-\begin{code}
-mkRuntimeErrorApp 
-        :: Id           -- Should be of type (forall a. Addr# -> a)
-                        --      where Addr# points to a UTF8 encoded string
-        -> Type         -- The type to instantiate 'a'
-        -> String       -- The string to print
-        -> CoreExpr
-
-mkRuntimeErrorApp err_id res_ty err_msg 
-  = mkApps (Var err_id) [Type res_ty, err_string]
-  where
-    err_string = Lit (mkMachString err_msg)
-
-mkImpossibleExpr :: Type -> CoreExpr
-mkImpossibleExpr res_ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
-
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
-pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
-rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
-rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
-iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
-rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
-pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
-nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-
--- The runtime error Ids take a UTF8-encoded string as argument
-
-mkRuntimeErrorId :: Name -> Id
-mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
-
-runtimeErrorTy :: Type
-runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
-\end{code}
-
-\begin{code}
-eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id errorName errorTy
-
-errorTy  :: Type
-errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
-    -- Notice the openAlphaTyVar.  It says that "error" can be applied
-    -- to unboxed as well as boxed types.  This is OK because it never
-    -- returns, so the return type is irrelevant.
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection{Utilities}
-%*                                                                      *
-%************************************************************************
-
 \begin{code}
 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
 pcMiscPrelId name ty info
@@ -1155,26 +1066,4 @@ pcMiscPrelId name ty info
     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
     -- being compiled, then it's just a matter of luck if the definition
     -- will be in "the right place" to be in scope.
-
-pc_bottoming_Id :: Name -> Type -> Id
--- Function of arity 1, which diverges after being given one argument
-pc_bottoming_Id name ty
- = pcMiscPrelId name ty bottoming_info
- where
-    bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
-                                  `setArityInfo`         1
-                       -- Make arity and strictness agree
-
-        -- Do *not* mark them as NoCafRefs, because they can indeed have
-        -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
-        -- which has some CAFs
-        -- In due course we may arrange that these error-y things are
-        -- regarded by the GC as permanently live, in which case we
-        -- can give them NoCaf info.  As it is, any function that calls
-        -- any pc_bottoming_Id will itself have CafRefs, which bloats
-        -- SRTs.
-
-    strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-        -- These "bottom" out, no matter what their arguments
 \end{code}
-
index 5fd35ce..a0fa921 100644 (file)
@@ -25,8 +25,8 @@
 -- Global 'Id's and 'Var's are those that are imported or correspond to a data constructor, primitive operation, or record selectors.
 -- Local 'Id's and 'Var's are those bound within an expression (e.g. by a lambda) or at the top level of the module being compiled.
 module Var (
-        -- * The main data type
-       Var,
+        -- * The main data type and synonyms
+       Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
 
        -- ** Taking 'Var's apart
        varName, varUnique, varType, 
@@ -41,14 +41,11 @@ module Var (
        setIdExported, setIdNotExported,
 
         -- ** Predicates
-        isCoVar, isId, isTyVar, isTcTyVar,
+        isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
         isLocalVar, isLocalId,
        isGlobalId, isExportedId,
        mustHaveLocalBinding,
 
-       -- * Type variable data type
-       TyVar,
-
        -- ** Constructing 'TyVar's
        mkTyVar, mkTcTyVar, mkWildCoVar,
 
@@ -58,9 +55,6 @@ module Var (
        -- ** Modifying 'TyVar's
        setTyVarName, setTyVarUnique, setTyVarKind,
 
-        -- * Coercion variable data type
-        CoVar,
-
         -- ** Constructing 'CoVar's
         mkCoVar,
 
@@ -68,10 +62,8 @@ module Var (
         coVarName,
 
         -- ** Modifying 'CoVar's
-        setCoVarUnique, setCoVarName,
+        setCoVarUnique, setCoVarName
 
-       -- * 'Var' type synonyms
-       Id, DictId
     ) where
 
 #include "HsVersions.h"
@@ -95,6 +87,30 @@ import Data.Data
 
 %************************************************************************
 %*                                                                     *
+                     Synonyms                                                                  
+%*                                                                     *
+%************************************************************************
+-- These synonyms are here and not in Id because otherwise we need a very
+-- large number of SOURCE imports of Id.hs :-(
+
+\begin{code}
+type EvVar = Var       -- An evidence variable: dictionary or equality constraint
+                       -- Could be an DictId or a CoVar
+
+type Id     = Var       -- A term-level identifier
+type DFunId = Id       -- A dictionary function
+type EvId   = Id        -- Term-level evidence: DictId or IpId
+type DictId = EvId     -- A dictionary variable
+type IpId   = EvId      -- A term-level implicit parameter
+
+type TyVar = Var
+type CoVar = TyVar     -- A coercion variable is simply a type 
+                       -- variable of kind @ty1 ~ ty2@. Hence its
+                       -- 'varType' is always @PredTy (EqPred t1 t2)@
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsection{The main data type declarations}
 %*                                                                     *
 %************************************************************************
@@ -124,7 +140,7 @@ data Var
        varName        :: !Name,
        realUnique     :: FastInt,
        varType        :: Kind,
-       tcTyVarDetails :: TcTyVarDetails }
+       tc_tv_details  :: TcTyVarDetails }
 
   | Id {
        varName    :: !Name,
@@ -166,7 +182,7 @@ instance Outputable Var where
 
 ppr_debug :: Var -> SDoc
 ppr_debug (TyVar {})                          = ptext (sLit "tv")
-ppr_debug (TcTyVar {tcTyVarDetails = d})      = pprTcTyVarDetails d
+ppr_debug (TcTyVar {tc_tv_details = d})       = pprTcTyVarDetails d
 ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
 
 ppr_id_scope :: IdScope -> SDoc
@@ -229,8 +245,6 @@ setVarType id ty = id { varType = ty }
 %************************************************************************
 
 \begin{code}
-type TyVar = Var
-
 tyVarName :: TyVar -> Name
 tyVarName = varName
 
@@ -262,8 +276,12 @@ mkTcTyVar name kind details
     TcTyVar {  varName    = name,
                realUnique = getKeyFastInt (nameUnique name),
                varType  = kind,
-               tcTyVarDetails = details
+               tc_tv_details = details
        }
+
+tcTyVarDetails :: TyVar -> TcTyVarDetails
+tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
+tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
 \end{code}
 
 %************************************************************************
@@ -273,10 +291,6 @@ mkTcTyVar name kind details
 %************************************************************************
 
 \begin{code}
-type CoVar = TyVar -- A coercion variable is simply a type 
-                       -- variable of kind @ty1 ~ ty2@. Hence its
-                       -- 'varType' is always @PredTy (EqPred t1 t2)@
-
 coVarName :: CoVar -> Name
 coVarName = varName
 
@@ -307,11 +321,6 @@ mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
 %************************************************************************
 
 \begin{code}
--- These synonyms are here and not in Id because otherwise we need a very
--- large number of SOURCE imports of Id.hs :-(
-type Id = Var
-type DictId = Var
-
 idInfo :: Id -> IdInfo
 idInfo (Id { id_info = info }) = info
 idInfo other                  = pprPanic "idInfo" (ppr other)
@@ -375,11 +384,20 @@ setIdNotExported id = ASSERT( isLocalId id )
 %************************************************************************
 
 \begin{code}
-isTyVar :: Var -> Bool         -- True of both type and coercion variables
-isTyVar (TyVar {})   = True
+isTyCoVar :: Var -> Bool       -- True of both type and coercion variables
+isTyCoVar (TyVar {})   = True
+isTyCoVar (TcTyVar {}) = True
+isTyCoVar _            = False
+
+isTyVar :: Var -> Bool         -- True of both type variables only
+isTyVar v@(TyVar {}) = not (isCoercionVar v)
 isTyVar (TcTyVar {}) = True
 isTyVar _            = False
 
+isCoVar :: Var -> Bool         -- Only works after type checking (sigh)
+isCoVar v@(TyVar {}) = isCoercionVar v
+isCoVar _            = False
+
 isTcTyVar :: Var -> Bool
 isTcTyVar (TcTyVar {}) = True
 isTcTyVar _            = False
@@ -392,11 +410,6 @@ isLocalId :: Var -> Bool
 isLocalId (Id { idScope = LocalId _ }) = True
 isLocalId _                            = False
 
-isCoVar :: Var -> Bool
-isCoVar (v@(TyVar {}))             = isCoercionVar v
-isCoVar (TcTyVar {varType = kind}) = isCoercionKind kind  -- used during solving
-isCoVar _                          = False
-
 -- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's
 -- These are the variables that we need to pay attention to when finding free
 -- variables, or doing dependency analysis.
index 2ee5ea5..bf3f96d 100644 (file)
@@ -27,7 +27,8 @@ module VarEnv (
        -- ** Operations on InScopeSets
        emptyInScopeSet, mkInScopeSet, delInScopeSet,
        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
-       getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, 
+       getInScopeVars, lookupInScope, lookupInScope_Directly, 
+        elemInScopeSet, uniqAway, 
 
        -- * The RnEnv2 type
        RnEnv2, 
@@ -114,6 +115,10 @@ elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
 -- the variable's identity (unique) to its full value.
 lookupInScope :: InScopeSet -> Var -> Maybe Var
 lookupInScope (InScope in_scope _) v  = lookupVarEnv in_scope v
+
+lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
+lookupInScope_Directly (InScope in_scope _) uniq
+  = lookupVarEnv_Directly in_scope uniq
 \end{code}
 
 \begin{code}
index 2cadd8d..c4a16d3 100644 (file)
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmBuildInfoTables
     ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
     , setInfoTableSRT, setInfoTableStackMap
index c5bcdc3..17c11ce 100644 (file)
@@ -235,6 +235,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
       start_block = lookupWithDefaultBEnv blocks unknown_block start
       children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
+      unknown_block :: a    -- Used at more than one type
       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
       body = start_block : children_blocks
 
index 8bcadbb..e72d3f2 100644 (file)
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmCPSZ (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
@@ -153,7 +157,10 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
   where dflags = hsc_dflags hsc_env
         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+
+        run :: FuelMonad a -> IO a
         run = runFuelIO (hsc_OptFuel hsc_env)
+
         dual_rewrite flag txt pass g =
           do dump flag ("Pre " ++ txt)  g
              g <- run $ pass g
index df05a65..c457383 100644 (file)
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
 
 module CmmSpillReload
   ( DualLive(..)
index d9cd411..a62580b 100644 (file)
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmStackLayout
     ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
     , layout, manifestSP, igraph, areaBuilder
index 376ab3e..1001f23 100644 (file)
@@ -461,25 +461,32 @@ postorder_dfs g@(LGraph _ blockenv) =
     let FGraph id eblock _ = entry g in
      zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
 
-postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
+postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l)
                           => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
-postorder_dfs_from_except blocks b visited =
-  vchildren (get_children b) (\acc _visited -> acc) [] visited
+postorder_dfs_from_except blocks b visited 
+  = vchildren (get_children b) (\acc _visited -> acc) [] visited
   where
-    -- vnode ::
-    --    Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
+    vnode :: Block m l -> ([Block m l] -> BlockSet -> a)
+          -> [Block m l] -> BlockSet -> a
     vnode block@(Block id _) cont acc visited =
         if elemBlockSet id visited then
             cont acc visited
         else
             let cont' acc visited = cont (block:acc) visited in
             vchildren (get_children block) cont' acc (extendBlockSet visited id)
+
+    vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a)
+              -> [Block m l] -> BlockSet -> a
     vchildren bs cont acc visited =
         let next children acc visited =
                 case children of []     -> cont acc visited
                                  (b:bs) -> vnode b (next bs) acc visited
         in next bs acc visited
+
+    get_children :: HavingSuccessors c => c -> [Block m l]
     get_children block = foldl add_id [] (succs block)
+
+    add_id :: [Block m l] -> BlockId -> [Block m l]
     add_id rst id = case lookupBlockEnv blocks id of
                       Just b -> b : rst
                       Nothing -> rst
index 0a494f8..1377e2f 100644 (file)
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what
 -- they're doing.  Clients that need to create flow graphs should
index ba8e75a..388d99c 100644 (file)
@@ -528,8 +528,14 @@ forward_sol check_maybe = forw
                ; b <-  finish
                ; return (b, fuel)
                }
+
        -- The need for both k1 and k2 suggests that maybe there's an opportunity
        -- for improvement here -- in most cases, they're the same...
+       rec_rewrite :: forall t bI bW.
+                      Maybe (AGraph m l) -> t -> DFM a bW
+                   -> (t -> Fuel -> DFM a bI)
+                   -> (bW -> Fuel -> DFM a bI)
+                   -> a -> Fuel -> DFM a bI
        rec_rewrite rewritten analyzed finish k1 k2 in' fuel =
          case check_maybe fuel rewritten of -- fr_first rewrites id idfact of
            Nothing -> k1 analyzed fuel
@@ -589,7 +595,6 @@ forward_rew
         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 forward_rew check_maybe = forw
   where
-    solve = forward_sol check_maybe
     forw :: RewritingDepth
          -> BlockEnv a
          -> PassName
@@ -607,7 +612,8 @@ forward_rew check_maybe = forw
            in_fact `seq` g `seq`
             let Graph entry blockenv = g
                 blocks = G.postorder_dfs_from blockenv entry
-            in do { _ <- solve depth name start transfers rewrites in_fact g fuel
+            in do { _ <- forward_sol check_maybe depth name start 
+                                     transfers rewrites in_fact g fuel
                   ; eid <- freshBlockId "temporary entry id"
                   ; (rewritten, fuel) <-
                       rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
@@ -615,11 +621,18 @@ forward_rew check_maybe = forw
                   ; a <- finish
                   ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
                   }
+
+          don't_rewrite :: forall t.
+                           BlockEnv a -> DFM a t -> a
+                        -> Graph m l -> Fuel
+                        -> DFM a (t, Graph m l, Fuel)
           don't_rewrite facts finish in_fact g fuel =
-              do  { _ <- solve depth name facts transfers rewrites in_fact g fuel
+              do  { _ <- forward_sol check_maybe depth name facts 
+                                     transfers rewrites in_fact g fuel
                   ; a <- finish
                   ; return (a, g, fuel)
                   }
+
           inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
           inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
               where inner_rew' = case depth of RewriteShallow -> don't_rewrite
@@ -633,6 +646,7 @@ forward_rew check_maybe = forw
                  ; let fp = FFP cfp last_outs
                  ; return (fp, fuel)
                  }
+
 -- JD: WHY AREN'T WE TAKING ANY FUEL HERE?
           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
@@ -1028,8 +1042,9 @@ run dir name do_block blocks b =
      pprFacts depth n env =
          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
                         (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
-     pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
+pprFact :: (Outputable a, Outputable b) => (a,b) -> SDoc
+pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
 f4sep :: [SDoc] -> SDoc
 f4sep [] = fsep []
index e63d121..666da70 100644 (file)
@@ -612,7 +612,7 @@ etaExpand n orig_expr
       -- Strip off existing lambdas and casts
       -- Note [Eta expansion and SCCs]
     go 0 expr = expr
-    go n (Lam v body) | isTyVar v = Lam v (go n     body)
+    go n (Lam v body) | isTyCoVar v = Lam v (go n     body)
                              | otherwise = Lam v (go (n-1) body)
     go n (Cast expr co) = Cast (go n expr) co
     go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
@@ -655,7 +655,7 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
 etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) 
   = etaInfoApp subst' e eis
   where
-    subst' | isTyVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) 
+    subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) 
           | otherwise  = CoreSubst.extendIdSubst subst v1 (Var v2)
 
 etaInfoApp subst (Cast e co1) eis
index 46c21b2..e5cbfc4 100644 (file)
@@ -395,7 +395,7 @@ idFreeVars id = ASSERT( isId id)
 bndrRuleAndUnfoldingVars ::Var -> VarSet
 -- A 'let' can bind a type variable, and idRuleVars assumes 
 -- it's seeing an Id. This function tests first.
-bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
+bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
                           | otherwise = idRuleAndUnfoldingVars v
 
 idRuleAndUnfoldingVars :: Id -> VarSet
index c267c96..119b232 100644 (file)
@@ -229,9 +229,9 @@ lintCoreExpr (Note _ expr)
   = lintCoreExpr expr
 
 lintCoreExpr (Let (NonRec tv (Type ty)) body)
-  =    -- See Note [Type let] in CoreSyn
-    do { checkL (isTyVar tv) (mkKindErrMsg tv ty)      -- Not quite accurate
-       ; ty' <- lintInTy ty
+  | isTyVar tv
+  =    -- See Note [Linting type lets]
+    do { ty' <- addLoc (RhsOf tv) $ lintInTy ty
         ; lintTyBndr tv              $ \ tv' -> 
           addLoc (BodyOfLetRec [tv]) $ 
           extendSubstL tv' ty'       $ do
@@ -240,6 +240,19 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
                -- take advantage of it in the body
         ; lintCoreExpr body } }
 
+  | isCoVar tv
+  = do { co <- applySubst ty
+       ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
+       ; lintTyBndr tv  $ \ tv' -> 
+         addLoc (BodyOfLetRec [tv]) $ do
+       { let (t1,t2) = coVarKind tv'
+       ; checkTys s1 t1 (mkTyVarLetErr tv ty)
+       ; checkTys s2 t2 (mkTyVarLetErr tv ty)
+       ; lintCoreExpr body } }
+
+  | otherwise
+  = failWithL (mkTyVarLetErr tv ty)    -- Not quite accurate
+
 lintCoreExpr (Let (NonRec bndr rhs) body)
   = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
        ; addLoc (BodyOfLetRec [bndr])
@@ -279,7 +292,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
          Just (tycon, _)
               | debugIsOn &&
                 isAlgTyCon tycon && 
-               not (isOpenTyCon tycon) &&
+               not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
                 null (tyConDataCons tycon) -> 
                   pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
                        -- This can legitimately happen for type families
@@ -1081,6 +1094,14 @@ mkNonFunAppMsg fun_ty arg_ty arg
              hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
              hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 
+mkTyVarLetErr :: TyVar -> Type -> Message
+mkTyVarLetErr tyvar ty
+  = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
+         hang (ptext (sLit "Type/coercion variable:"))
+                4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+         hang (ptext (sLit "Arg type/coercion:"))   
+                4 (ppr ty)]
+
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext (sLit "Kinds don't match in type application:"),
index ba178b5..6a5a251 100644 (file)
@@ -465,7 +465,7 @@ rhsToBody (Cast e co)
 rhsToBody expr@(Lam {})
   | Just no_lam_result <- tryEtaReducePrep bndrs body
   = return (emptyFloats, no_lam_result)
-  | all isTyVar bndrs          -- Type lambdas are ok
+  | all isTyCoVar bndrs                -- Type lambdas are ok
   = return (emptyFloats, expr)
   | otherwise                  -- Some value lambdas
   = do { fn <- newVar (exprType expr)
@@ -688,7 +688,7 @@ cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial
 cpe_ExprIsTrivial (Note (SCC _) _)         = False
 cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False
 \end{code}
 
index 3578037..4f92b1a 100644 (file)
@@ -28,7 +28,7 @@ module CoreSubst (
        cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
 
        -- ** Simple expression optimiser
-       simpleOptExpr
+       simpleOptPgm, simpleOptExpr
     ) where
 
 #include "HsVersions.h"
@@ -36,10 +36,12 @@ module CoreSubst (
 import CoreSyn
 import CoreFVs
 import CoreUtils
-import OccurAnal( occurAnalyseExpr )
+import PprCore
+import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
 
 import qualified Type
 import Type     ( Type, TvSubst(..), TvSubstEnv )
+import Coercion           ( isIdentityCoercion )
 import OptCoercion ( optCoercion )
 import VarSet
 import VarEnv
@@ -50,6 +52,8 @@ import IdInfo
 import Unique
 import UniqSupply
 import Maybes
+import ErrUtils
+import DynFlags   ( DynFlags, DynFlag(..) )
 import BasicTypes ( isAlwaysActive )
 import Outputable
 import PprCore         ()              -- Instances
@@ -203,7 +207,7 @@ extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEn
 -- 'extendIdSubst' and 'extendTvSubst'
 extendSubst :: Subst -> Var -> CoreArg -> Subst
 extendSubst (Subst in_scope ids tvs) tv (Type ty)
-  = ASSERT( isTyVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
+  = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
 extendSubst (Subst in_scope ids tvs) id expr
   = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
 
@@ -301,7 +305,11 @@ subst_expr subst expr
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
-    go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
+    go (Cast e co) 
+      | isIdentityCoercion co' = go e
+      | otherwise              = Cast (go e) co'
+      where
+        co' = optCoercion (getTvSubst subst) co
        -- Optimise coercions as we go; this is good, for example
        -- in the RHS of rules, which are only substituted in
 
@@ -385,8 +393,8 @@ preserve occ info in rules.
 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
 substBndr :: Subst -> Var -> (Subst, Var)
 substBndr subst bndr
-  | isTyVar bndr  = substTyVarBndr subst bndr
-  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
+  | isTyCoVar bndr  = substTyVarBndr subst bndr
+  | otherwise       = substIdBndr (text "var-bndr") subst subst bndr
 
 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
 substBndrs :: Subst -> [Var] -> (Subst, [Var])
@@ -521,7 +529,6 @@ substIdType subst@(Subst _ _ tv_env) id
 
 ------------------
 -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
--- Always zaps the unfolding, to save substitution work
 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
 substIdInfo subst new_id info
   | nothing_to_do = Nothing
@@ -601,7 +608,9 @@ substSpec subst new_id (SpecInfo rules rhs_fvs)
 ------------------
 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
 substRulesForImportedIds subst rules 
-  = map (substRule subst (\name -> name)) rules
+  = map (substRule subst not_needed) rules
+  where
+    not_needed name = pprPanic "substRulesForImportedIds" (ppr name)
 
 ------------------
 substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
@@ -615,9 +624,12 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
 
 substRule _ _ rule@(BuiltinRule {}) = rule
 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
-                                       , ru_fn = fn_name, ru_rhs = rhs })
+                                       , ru_fn = fn_name, ru_rhs = rhs
+                                       , ru_local = is_local })
   = rule { ru_bndrs = bndrs', 
-          ru_fn    = subst_ru_fn fn_name,
+          ru_fn    = if is_local 
+                       then subst_ru_fn fn_name 
+                       else fn_name,
           ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
           ru_rhs   = substExpr (text "subst-rule" <+> ppr fn_name) subst' rhs }
   where
@@ -664,7 +676,7 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 
 simpleOptExpr expr
   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
-    go init_subst (occurAnalyseExpr expr)
+    simple_opt_expr init_subst (occurAnalyseExpr expr)
   where
     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
        -- It's potentially important to make a proper in-scope set
@@ -677,74 +689,173 @@ simpleOptExpr expr
        -- It's a bit painful to call exprFreeVars, because it makes
        -- three passes instead of two (occ-anal, and go)
 
-    go subst (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
-    go subst (App e1 e2)      = App (go subst e1) (go subst e2)
-    go subst (Type ty)        = Type (substTy subst ty)
-    go _     (Lit lit)        = Lit lit
-    go subst (Note note e)    = Note note (go subst e)
-    go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
-    go subst (Let bind body)  = go_let subst bind body
-    go subst (Lam bndr body)  = Lam bndr' (go subst' body)
-                             where
-                               (subst', bndr') = substBndr subst bndr
-
-    go subst (Case e b ty as) = Case (go subst e) b' 
-                                    (substTy subst ty)
-                                    (map (go_alt subst') as)
-                             where
-                                (subst', b') = substBndr subst b
+----------------------
+simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
+simpleOptPgm dflags binds rules
+  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+                      (pprCoreBindings occ_anald_binds);
 
+       ; return (reverse binds', substRulesForImportedIds subst' rules) }
+  where
+    occ_anald_binds  = occurAnalysePgm binds rules
+    (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
+                       
+    do_one (subst, binds') bind 
+      = case simple_opt_bind subst bind of
+          (subst', Nothing)    -> (subst', binds')
+          (subst', Just bind') -> (subst', bind':binds')
+
+----------------------
+type InVar   = Var
+type OutVar  = Var
+type InId    = Id
+type OutId   = Id
+type InExpr  = CoreExpr
+type OutExpr = CoreExpr
+
+-- In these functions the substitution maps InVar -> OutExpr
+
+----------------------
+simple_opt_expr :: Subst -> InExpr -> OutExpr
+simple_opt_expr subst expr
+  = go expr
+  where
+    go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
+    go (App e1 e2)      = App (go e1) (go e2)
+    go (Type ty)        = Type (substTy subst ty)
+    go (Lit lit)        = Lit lit
+    go (Note note e)    = Note note (go e)
+    go (Cast e co)      | isIdentityCoercion co' = go e
+                               | otherwise              = Cast (go e) co' 
+                        where
+                          co' = substTy subst co
+
+    go (Let bind body)  = maybeLet mb_bind (simple_opt_expr subst' body)
+                        where
+                          (subst', mb_bind) = simple_opt_bind subst bind
+    go lam@(Lam {})     = go_lam [] subst lam
+    go (Case e b ty as) = Case (go e) b' (substTy subst ty)
+                                      (map (go_alt subst') as)
+                               where
+                                 (subst', b') = subst_opt_bndr subst b
 
     ----------------------
-    go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
-                                where
-                                  (subst', bndrs') = substBndrs subst bndrs
-
-    ----------------------
-    go_let subst (Rec prs) body
-      = Let (Rec (reverse rev_prs')) (go subst'' body)
+    go_alt subst (con, bndrs, rhs) 
+      = (con, bndrs', simple_opt_expr subst' rhs)
       where
-       (subst', bndrs')    = substRecBndrs subst (map fst prs)
-       (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
-       do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of
-                                          Left subst' -> (subst', prs)
-                                          Right r'    -> (subst,  (b',r'):prs)
-
-    go_let subst (NonRec b r) body
-      = case go_bind subst b r of
-          Left subst' -> go subst' body
-         Right r'    -> Let (NonRec b' r') (go subst' body)
-                     where
-                        (subst', b') = substBndr subst b
-
+       (subst', bndrs') = subst_opt_bndrs subst bndrs
 
     ----------------------
-    go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr
-        -- (go_bind subst old_var old_rhs)  
-       --   either extends subst with (old_var -> new_rhs)
-       --   or     return new_rhs for a binding new_var = new_rhs
-    go_bind subst b r
-      | Type ty <- r
-      , isTyVar b      -- let a::* = TYPE ty in <body>
-      = Left (extendTvSubst subst b (substTy subst ty))
-
-      | isId b         -- let x = e in <body>
-      , safe_to_inline (idOccInfo b) || exprIsTrivial r'
-      , isAlwaysActive (idInlineActivation b)  -- Note [Inline prag in simplOpt]
-      = Left (extendIdSubst subst b r')
-      
-      | otherwise
-      = Right r'
-      where
-        r' = go subst r
+    -- go_lam tries eta reduction
+    go_lam bs' subst (Lam b e) 
+       = go_lam (b':bs') subst' e
+       where
+         (subst', b') = subst_opt_bndr subst b
+    go_lam bs' subst e 
+       | Just etad_e <- tryEtaReduce bs e' = etad_e
+       | otherwise                         = mkLams bs e'
+       where
+         bs = reverse bs'
+         e' = simple_opt_expr subst e
+
+----------------------
+simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
+simple_opt_bind subst (Rec prs)
+  = (subst'', Just (Rec (reverse rev_prs')))
+  where
+    (subst', bndrs')    = subst_opt_bndrs subst (map fst prs)
+    (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
+    do_pr (subst, prs) ((b,r), b') = case simple_opt_pair subst b r of
+                                      Left subst' -> (subst', prs)
+                                      Right r'    -> (subst,  (b2,r'):prs)
+                                           where
+                                            b2 = add_info subst b b'
+
+simple_opt_bind subst (NonRec b r)
+  = case simple_opt_pair subst b r of
+      Left ext_subst -> (ext_subst, Nothing)
+      Right r'       -> (subst', Just (NonRec b2 r'))
+                    where
+                       (subst', b') = subst_opt_bndr subst b
+                       b2 = add_info subst' b b'
+
+----------------------
+simple_opt_pair :: Subst -> InVar -> InExpr -> Either Subst OutExpr
+    -- (simple_opt_pair subst in_var in_rhs)  
+    --   either extends subst with (in_var -> out_rhs)
+    --   or     return out_rhs for a binding out_var = out_rhs
+simple_opt_pair subst b r
+  | Type ty <- r       -- let a::* = TYPE ty in <body>
+  = ASSERT( isTyCoVar b )
+    Left (extendTvSubst subst b (substTy subst ty))
+
+  | isId b             -- let x = e in <body>
+  , safe_to_inline (idOccInfo b) 
+  , isAlwaysActive (idInlineActivation b)      -- Note [Inline prag in simplOpt]
+  , not (isStableUnfolding (idUnfolding b))
+  , not (isExportedId b)
+  = Left (extendIdSubst subst b r')
+  
+  | otherwise
+  = Right r'
+  where
+    r' = simple_opt_expr subst r
 
-    ----------------------
        -- Unconditionally safe to inline
     safe_to_inline :: OccInfo -> Bool
-    safe_to_inline IAmDead                  = True
-    safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
     safe_to_inline (IAmALoopBreaker {})     = False
-    safe_to_inline NoOccInfo                = False
+    safe_to_inline IAmDead                  = True
+    safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || exprIsTrivial r'
+    safe_to_inline NoOccInfo                = exprIsTrivial r'
+
+----------------------
+subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
+subst_opt_bndr subst bndr
+  | isTyCoVar bndr  = substTyVarBndr subst bndr
+  | otherwise       = subst_opt_id_bndr subst bndr
+
+subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
+-- Nuke all fragile IdInfo, unfolding, and RULES; 
+--    it gets added back later by add_info
+-- Rather like SimplEnv.substIdBndr
+--
+-- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr 
+-- carefully does not do) because simplOptExpr invalidates it
+
+subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id
+  = (Subst new_in_scope new_id_subst tv_subst, new_id)
+  where
+    id1           = uniqAway in_scope old_id
+    id2    = setIdType id1 (substTy subst (idType old_id))
+    new_id = zapFragileIdInfo id2      -- Zaps rules, worker-info, unfolding
+                                       -- and fragile OccInfo
+    new_in_scope = in_scope `extendInScopeSet` new_id
+
+       -- Extend the substitution if the unique has changed,
+       -- or there's some useful occurrence information
+       -- See the notes with substTyVarBndr for the delSubstEnv
+    new_id_subst | new_id /= old_id
+                = extendVarEnv id_subst old_id (Var new_id)
+                | otherwise 
+                = delVarEnv id_subst old_id
+
+----------------------
+subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar])
+subst_opt_bndrs subst bndrs
+  = mapAccumL subst_opt_bndr subst bndrs
+
+----------------------
+add_info :: Subst -> InVar -> OutVar -> OutVar
+add_info subst old_bndr new_bndr 
+ | isTyCoVar old_bndr = new_bndr
+ | otherwise          = maybeModifyIdInfo mb_new_info new_bndr
+ where
+   mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
+
+----------------------
+maybeLet :: Maybe CoreBind -> CoreExpr -> CoreExpr
+maybeLet Nothing  e = e
+maybeLet (Just b) e = Let b e
 \end{code}
 
 Note [Inline prag in simplOpt]
@@ -764,4 +875,5 @@ we don't know what phase we're in.  Here's an example
   bar n = foo n 1
 
 When inlining 'foo' in 'bar' we want the let-binding for 'inner' 
-to remain visible until Phase 1
\ No newline at end of file
+to remain visible until Phase 1
+
index b7a859f..2ad111f 100644 (file)
@@ -26,7 +26,7 @@ module CoreSyn (
        mkConApp, mkTyBind,
        varToCoreExpr, varsToCoreExprs,
 
-        isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
+        isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
        
        -- ** Simple 'Expr' access functions and predicates
        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
@@ -87,7 +87,7 @@ import Util
 import Data.Data
 import Data.Word
 
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
 \end{code}
 
@@ -100,8 +100,6 @@ infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
 These data types are the heart of the compiler
 
 \begin{code}
-infixl 8 `App` -- App brackets to the left
-
 -- | This is the data type that represents GHCs core intermediate language. Currently
 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
@@ -975,7 +973,7 @@ collectTyAndValBinders expr
 collectTyBinders expr
   = go [] expr
   where
-    go tvs (Lam b e) | isTyVar b = go (b:tvs) e
+    go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
     go tvs e                    = (reverse tvs, e)
 
 collectValBinders expr
index b77186e..c928be4 100644 (file)
@@ -17,7 +17,7 @@ import CoreSyn
 import CoreArity
 import Id
 import IdInfo
-import Type
+import TcType( tidyType, tidyTyVarBndr )
 import Var
 import VarEnv
 import UniqFM
@@ -123,7 +123,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var
-  | isTyVar var = tidyTyVarBndr env var
+  | isTyCoVar var = tidyTyVarBndr env var
   | otherwise   = tidyIdBndr env var
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
index 0a398d1..24d6330 100644 (file)
@@ -1112,7 +1112,7 @@ interestingArg e = go e 0
     go (Note _ a)       n = go a n
     go (Cast e _)       n = go e n
     go (Lam v e)        n 
-       | isTyVar v        = go e n
+       | isTyCoVar v      = go e n
        | n>0              = go e (n-1)
        | otherwise        = ValueArg
     go (Let _ e)        n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
index 05ef9a3..1a21704 100644 (file)
@@ -38,6 +38,9 @@ module CoreUtils (
        -- * Equality
        cheapEqExpr, eqExpr, eqExprX,
 
+       -- * Eta reduction
+       tryEtaReduce,
+
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
         dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
@@ -109,7 +112,7 @@ coreAltType (_,bs,rhs)
   where
     ty           = exprType rhs
     free_tvs     = tyVarsOfType ty
-    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
+    bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs
 
 coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -142,10 +145,10 @@ Various possibilities suggest themselves:
    we are doing here.  It's not too expensive, I think.
 
 \begin{code}
-mkPiType  :: Var   -> Type -> Type
+mkPiType  :: EvVar -> Type -> Type
 -- ^ Makes a @(->)@ type or a forall type, depending
 -- on whether it is given a type variable or a term variable.
-mkPiTypes :: [Var] -> Type -> Type
+mkPiTypes :: [EvVar] -> Type -> Type
 -- ^ 'mkPiType' for multiple type or value arguments
 
 mkPiType v ty
@@ -195,7 +198,7 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 \begin{code}
 -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
 mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
-mkCoerceI IdCo e = e
+mkCoerceI (IdCo _) e = e
 mkCoerceI (ACo co) e = mkCoerce co e
 
 -- | Wrap the given expression in the coercion safely, coalescing nested coercions
@@ -1077,7 +1080,7 @@ noteSize (SCC cc)       = cc `seq` 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
  
 varSize :: Var -> Int
-varSize b  | isTyVar b = 1
+varSize b  | isTyCoVar b = 1
           | otherwise = seqType (idType b)             `seq`
                         megaSeqIdInfo (idInfo b)       `seq`
                         1
@@ -1161,6 +1164,100 @@ hashVar (_,env) v
  = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
 \end{code}
 
+
+%************************************************************************
+%*                                                                     *
+               Eta reduction
+%*                                                                     *
+%************************************************************************
+
+Note [Eta reduction conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We try for eta reduction here, but *only* if we get all the way to an
+trivial expression.  We don't want to remove extra lambdas unless we
+are going to avoid allocating this thing altogether.
+
+There are some particularly delicate points here:
+
+* Eta reduction is not valid in general:  
+       \x. bot  /=  bot
+  This matters, partly for old-fashioned correctness reasons but,
+  worse, getting it wrong can yield a seg fault. Consider
+       f = \x.f x
+       h y = case (case y of { True -> f `seq` True; False -> False }) of
+               True -> ...; False -> ...
+
+  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
+  says f=bottom, and replaces the (f `seq` True) with just
+  (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it
+  *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands 
+  the definition again, so that it does not termninate after all.
+  Result: seg-fault because the boolean case actually gets a function value.
+  See Trac #1947.
+
+  So it's important to to the right thing.
+
+* Note [Arity care]: we need to be careful if we just look at f's
+  arity. Currently (Dec07), f's arity is visible in its own RHS (see
+  Note [Arity robustness] in SimplEnv) so we must *not* trust the
+  arity when checking that 'f' is a value.  Otherwise we will
+  eta-reduce
+      f = \x. f x
+  to
+      f = f
+  Which might change a terminiating program (think (f `seq` e)) to a 
+  non-terminating one.  So we check for being a loop breaker first.
+
+  However for GlobalIds we can look at the arity; and for primops we
+  must, since they have no unfolding.  
+
+* Regardless of whether 'f' is a value, we always want to 
+  reduce (/\a -> f a) to f
+  This came up in a RULE: foldr (build (/\a -> g a))
+  did not match          foldr (build (/\b -> ...something complex...))
+  The type checker can insert these eta-expanded versions,
+  with both type and dictionary lambdas; hence the slightly 
+  ad-hoc isDictId
+
+* Never *reduce* arity. For example
+      f = \xy. g x y
+  Then if h has arity 1 we don't want to eta-reduce because then
+  f's arity would decrease, and that is bad
+
+These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
+Alas.
+
+\begin{code}
+tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
+tryEtaReduce bndrs body 
+  = go (reverse bndrs) body
+  where
+    incoming_arity = count isId bndrs
+
+    go (b : bs) (App fun arg) | ok_arg b arg = go bs fun       -- Loop round
+    go []       fun           | ok_fun fun   = Just fun                -- Success!
+    go _        _                           = Nothing          -- Failure!
+
+       -- Note [Eta reduction conditions]
+    ok_fun (App fun (Type ty)) 
+       | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+       =  ok_fun fun
+    ok_fun (Var fun_id)
+       =  not (fun_id `elem` bndrs)
+       && (ok_fun_id fun_id || all ok_lam bndrs)
+    ok_fun _fun = False
+
+    ok_fun_id fun = fun_arity fun >= incoming_arity
+
+    fun_arity fun            -- See Note [Arity care]
+       | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
+       | otherwise = idArity fun             
+
+    ok_lam v = isTyCoVar v || isDictId v
+
+    ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection{Determining non-updatable right-hand-sides}
index 7714b58..3e0ad62 100644 (file)
@@ -4,7 +4,8 @@ module MkCore (
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
-        mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
+        mkCoreLams, mkWildCase, mkIfThenElse,
+        mkWildValBinder, mkWildEvBinder,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -38,7 +39,7 @@ module MkCore (
 #include "HsVersions.h"
 
 import Id
-import Var      ( setTyVarUnique )
+import Var      ( EvVar, mkWildCoVar, setTyVarUnique )
 
 import CoreSyn
 import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
@@ -128,7 +129,7 @@ mk_val_app fun arg arg_ty _        -- See Note [CoreSyn let/app invariant]
 mk_val_app fun arg arg_ty res_ty
   = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
   where
-    arg_id = mkWildBinder arg_ty    
+    arg_id = mkWildValBinder arg_ty    
        -- Lots of shadowing, but it doesn't matter,
         -- because 'fun ' should not have a free wild-id
        --
@@ -138,19 +139,22 @@ mk_val_app fun arg arg_ty res_ty
        -- is if you take apart this case expression, and pass a 
        -- fragmet of it as the fun part of a 'mk_val_app'.
 
+mkWildEvBinder :: PredType -> EvVar
+mkWildEvBinder pred@(EqPred {}) = mkWildCoVar     (mkPredTy pred)
+mkWildEvBinder pred             = mkWildValBinder (mkPredTy pred)
 
 -- | Make a /wildcard binder/. This is typically used when you need a binder 
 -- that you expect to use only at a *binding* site.  Do not use it at
 -- occurrence sites because it has a single, fixed unique, and it's very
 -- easy to get into difficulties with shadowing.  That's why it is used so little.
-mkWildBinder :: Type -> Id
-mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
+mkWildValBinder :: Type -> Id
+mkWildValBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
 
 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
 -- Make a case expression whose case binder is unused
 -- The alts should not have any occurrences of WildId
 mkWildCase scrut scrut_ty res_ty alts 
-  = Case scrut (mkWildBinder scrut_ty) res_ty alts
+  = Case scrut (mkWildValBinder scrut_ty) res_ty alts
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
index eae4b93..9b9ca5e 100644 (file)
@@ -145,7 +145,7 @@ make_exp (App e1 e2) = do
    rator <- make_exp e1
    rand <- make_exp e2
    return $ C.App rator rand
-make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
+make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Tb (make_tbind v)) b)
 make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Vb (make_vbind v)) b)
@@ -169,7 +169,7 @@ make_alt (DataAlt dcon, vs, e) = do
            (map make_tbind tbs)
            (map make_vbind vbs)
           newE
-       where (tbs,vbs) = span isTyVar vs
+       where (tbs,vbs) = span isTyCoVar vs
 make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 -- This should never happen, as the DEFAULT alternative binds no variables,
index 37e22cf..1908667 100644 (file)
@@ -247,7 +247,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyVar binder = pprKindedTyVarBndr binder
+  | isTyCoVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
                     ppIdInfo binder (idInfo binder)
 
@@ -258,7 +258,7 @@ pprCoreBinder bind_site bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyVar binder = ptext (sLit "@") <+> ppr binder   -- NB: don't print kind
+  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -266,7 +266,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 pprTypedLCBinder bind_site debug_on var
   | not debug_on && isDeadBinder var    = char '_'
   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
-  | isTyVar var                         = parens (pprKindedTyVarBndr var)
+  | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
               where
@@ -277,7 +277,7 @@ pprTypedLCBinder bind_site debug_on var
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyVar binder  = pprKindedTyVarBndr binder
+  | isTyCoVar binder  = pprKindedTyVarBndr binder
   | otherwise      = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
 pprKindedTyVarBndr :: TyVar -> SDoc
index 6bdc8a1..f32ce93 100644 (file)
@@ -138,9 +138,9 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
 addTickLHsBinds binds = mapBagM addTickLHsBind binds
 
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
-  abs_binds' <- addTickLHsBinds abs_binds
-  return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
+  binds' <- addTickLHsBinds binds
+  return $ L pos $ bind { abs_binds = binds' }
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
   let name = getOccString id
   decl_path <- getPathEntry
@@ -461,7 +461,7 @@ addTickStmt isGuard stmt@(RecStmt {})
        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; dicts' <- addTickDictBinds (recS_dicts stmt)
+       ; dicts' <- addTickEvBinds (recS_dicts stmt)
        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
                       , recS_mfix_fn = mfix', recS_bind_fn = bind'
                       , recS_dicts = dicts' }) }
@@ -507,7 +507,7 @@ addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
        liftM2 IPBinds
                (mapM (liftL (addTickIPBind)) ipbinds)
-               (addTickDictBinds dictbinds)
+               (return dictbinds)
 
 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 addTickIPBind (IPBind nm e) =
@@ -535,8 +535,8 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr x
 
-addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
-addTickDictBinds x = addTickLHsBinds x
+addTickEvBinds :: TcEvBinds -> TM TcEvBinds
+addTickEvBinds x = return x   -- No coverage testing for dictionary binding
 
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 addTickHsRecordBinds (HsRecFields fields dd) 
index 64fff0d..9616c62 100644 (file)
@@ -17,6 +17,7 @@ import MkIface
 import Id
 import Name
 import CoreSyn
+import CoreSubst
 import PprCore
 import DsMonad
 import DsExpr
@@ -27,6 +28,7 @@ import DsExpr         ()      -- Forces DsExpr to be compiled; DsBinds only
 import Module
 import RdrName
 import NameSet
+import NameEnv
 import Rules
 import CoreMonad       ( endPass, CoreToDo(..) )
 import ErrUtils
@@ -35,7 +37,9 @@ import SrcLoc
 import Maybes
 import FastString
 import Coverage
+import Util
 
+import Data.List
 import Data.IORef
 \end{code}
 
@@ -65,6 +69,7 @@ deSugar hsc_env
                            tcg_warns        = warns,
                            tcg_anns         = anns,
                            tcg_binds        = binds,
+                           tcg_ev_binds     = ev_binds,
                            tcg_fords        = fords,
                            tcg_rules        = rules,
                            tcg_insts        = insts,
@@ -83,42 +88,51 @@ deSugar hsc_env
               <- case target of
                   HscNothing ->
                        return (emptyMessages,
-                               Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
+                               Just ([], [], [], NoStubs, hpcInfo, emptyModBreaks))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
                         <- if (opt_Hpc
                                  || target == HscInterpreted)
                               && (not (isHsBoot hsc_src))
-                              then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds 
+                              then addCoverageTicksToBinds dflags mod mod_loc
+                                                           (typeEnvTyCons type_env) binds 
                               else return (binds, hpcInfo, emptyModBreaks)
                      initDs hsc_env mod rdr_env type_env $ do
+                        ds_ev_binds <- dsEvBinds ev_binds
                         core_prs <- dsTopLHsBinds auto_scc binds_cvr
                         (ds_fords, foreign_prs) <- dsForeigns fords
                         let all_prs = foreign_prs ++ core_prs
-                        ds_rules <- mapM dsRule rules
-                        return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
+                        mb_rules <- mapM dsRule rules
+                        return (ds_ev_binds, all_prs, mb_rules, ds_fords, ds_hpc_info, modBreaks)
 
        ; case mb_res of {
           Nothing -> return (msgs, Nothing) ;
-          Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
+          Just (ds_ev_binds, all_prs, mb_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
-       ; let final_prs = addExportFlags target export_set
-                                 keep_alive all_prs 
-             ds_binds  = [Rec final_prs]
+       ; let (rules_for_locals, rules_for_imps) 
+                   = partition isLocalRule (catMaybes mb_rules)
+              final_prs = addExportFlagsAndRules target
+                             export_set keep_alive rules_for_locals all_prs 
+
+              final_pgm = combineEvBinds ds_ev_binds final_prs
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
        -- When compiling PrelFloat, which defines data Float = F# Float#
        -- we want F# to be in scope in the foreign marshalling code!
        -- You might think it doesn't matter, but the simplifier brings all top-level
        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-       -- Lint result if necessary
-       ; endPass dflags CoreDesugar ds_binds ds_rules
+       -- Lint result if necessary, and print
+        ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
+               (vcat [ pprCoreBindings final_pgm
+                     , pprRules rules_for_imps ])
+
+       ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
+                        -- The simpleOptPgm gets rid of type 
+                        -- bindings plus any stupid dead code
 
-       -- Dump output
-       ; doIfSet (dopt Opt_D_dump_ds dflags) 
-                 (printDump (ppr_ds_rules ds_rules))
+       ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 
         ; used_names <- mkUsedNames tcg_env
        ; deps <- mkDependencies tcg_env
@@ -139,7 +153,7 @@ deSugar hsc_env
                mg_fam_insts    = fam_insts,
                mg_inst_env     = inst_env,
                mg_fam_inst_env = fam_inst_env,
-               mg_rules        = ds_rules,
+               mg_rules        = ds_rules_for_imps,
                mg_binds        = ds_binds,
                mg_foreign      = ds_fords,
                mg_hpc_info     = ds_hpc_info,
@@ -149,6 +163,33 @@ deSugar hsc_env
         ; return (msgs, Just mod_guts)
        }}}
 
+
+combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
+-- Top-level bindings can include coercion bindings, but not via superclasses
+-- See Note [Top-level evidence]
+combineEvBinds [] val_prs 
+  = [Rec val_prs]
+combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
+  | isId b    = combineEvBinds bs ((b,r):val_prs)
+  | otherwise = NonRec b r : combineEvBinds bs val_prs
+combineEvBinds (LetEvBind (Rec prs) : bs) val_prs 
+  = combineEvBinds bs (prs ++ val_prs)
+combineEvBinds (CaseEvBind x _ _ : _) _
+  = pprPanic "topEvBindPairs" (ppr x)
+\end{code}
+
+Note [Top-level evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level evidence bindings may be mutually recursive with the top-level value
+bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
+because the occurrence analyser doesn't teke account of type/coercion variables
+when computing dependencies.  
+
+So we pull out the type/coercion variables (which are in dependency order),
+and Rec the rest.
+
+
+\begin{code}
 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 mkAutoScc dflags mod exports
   | not opt_SccProfilingOn     -- No profiling
@@ -187,36 +228,45 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 
         return (msgs, Just expr)
+\end{code}
 
---             addExportFlags
--- Set the no-discard flag if either 
---     a) the Id is exported
---     b) it's mentioned in the RHS of an orphan rule
---     c) it's in the keep-alive set
---
--- It means that the binding won't be discarded EVEN if the binding
--- ends up being trivial (v = w) -- the simplifier would usually just 
--- substitute w for v throughout, but we don't apply the substitution to
--- the rules (maybe we should?), so this substitution would make the rule
--- bogus.
-
--- You might wonder why exported Ids aren't already marked as such;
--- it's just because the type checker is rather busy already and
--- I didn't want to pass in yet another mapping.
-
-addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)]
-               -> [(Id, t)]
-addExportFlags target exports keep_alive prs
-  = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
+%************************************************************************
+%*                                                                     *
+%*             Add rules and export flags to binders
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+addExportFlagsAndRules 
+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
+    -> [(Id, t)] -> [(Id, t)]
+addExportFlagsAndRules target exports keep_alive rules prs
+  = mapFst add_one prs
   where
-    add_export bndr
-       | dont_discard bndr = setIdExported bndr
+    add_one bndr = add_rules name (add_export name bndr)
+       where
+         name = idName bndr
+
+    ---------- Rules --------
+       -- See Note [Attach rules to local ids]
+       -- NB: the binder might have some existing rules,
+       -- arising from specialisation pragmas
+    add_rules name bndr
+       | Just rules <- lookupNameEnv rule_base name
+       = bndr `addIdSpecialisations` rules
+       | otherwise
+       = bndr
+    rule_base = extendRuleBaseList emptyRuleBase rules
+
+    ---------- Export flag --------
+    -- See Note [Adding export flags]
+    add_export name bndr
+       | dont_discard name = setIdExported bndr
        | otherwise         = bndr
 
-    dont_discard bndr = is_exported name
+    dont_discard :: Name -> Bool
+    dont_discard name = is_exported name
                     || name `elemNameSet` keep_alive
-                    where
-                       name = idName bndr
 
        -- In interactive mode, we don't want to discard any top-level
        -- entities at all (eg. do not inline them away during
@@ -228,15 +278,44 @@ addExportFlags target exports keep_alive prs
     is_exported :: Name -> Bool
     is_exported | target == HscInterpreted = isExternalName
                | otherwise                = (`elemNameSet` exports)
-
-ppr_ds_rules :: [CoreRule] -> SDoc
-ppr_ds_rules [] = empty
-ppr_ds_rules rules
-  = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$
-    pprRules rules
 \end{code}
 
 
+Note [Adding export flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Set the no-discard flag if either 
+       a) the Id is exported
+       b) it's mentioned in the RHS of an orphan rule
+       c) it's in the keep-alive set
+
+It means that the binding won't be discarded EVEN if the binding
+ends up being trivial (v = w) -- the simplifier would usually just 
+substitute w for v throughout, but we don't apply the substitution to
+the rules (maybe we should?), so this substitution would make the rule
+bogus.
+
+You might wonder why exported Ids aren't already marked as such;
+it's just because the type checker is rather busy already and
+I didn't want to pass in yet another mapping.
+
+Note [Attach rules to local ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Find the rules for locally-defined Ids; then we can attach them
+to the binders in the top-level bindings
+
+Reason
+  - It makes the rules easier to look up
+  - It means that transformation rules and specialisations for
+    locally defined Ids are handled uniformly
+  - It keeps alive things that are referred to only from a rule
+    (the occurrence analyser knows about rules attached to Ids)
+  - It makes sure that, when we apply a rule, the free vars
+    of the RHS are more likely to be in scope
+  - The imported rules are carried in the in-scope set
+    which is extended on each iteration by the new wave of
+    local binders; any rules which aren't on the binding will
+    thereby get dropped
+
 
 %************************************************************************
 %*                                                                     *
@@ -250,23 +329,24 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $ 
     do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
 
-       ; lhs'  <- unsetOptM Opt_EnableRewriteRules $
-                  dsLExpr lhs  -- Note [Desugaring RULE lhss]
+       ; lhs' <- unsetOptM Opt_EnableRewriteRules $
+                 dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 
-       ; rhs'  <- dsLExpr rhs
+       ; rhs' <- dsLExpr rhs
 
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
-       ; case decomposeRuleLhs (mkLams bndrs' lhs') of {
+       ; case decomposeRuleLhs lhs' of {
                Nothing -> do { warnDs msg; return Nothing } ;
-               Just (bndrs, fn_id, args) -> do
+               Just (fn_id, args) -> do
        
        { let local_rule = isLocalId fn_id
                -- NB: isLocalId is False of implicit Ids.  This is good becuase
                -- we don't want to attach rules to the bindings of implicit Ids, 
                -- because they don't show up in the bindings until just before code gen
-             fn_name = idName fn_id
-             rule    = mkRule local_rule name act fn_name bndrs args rhs' 
+             fn_name   = idName fn_id
+             final_rhs = simpleOptExpr rhs'    -- De-crap it
+             rule      = mkRule local_rule name act fn_name bndrs' args final_rhs
        ; return (Just rule)
        } } }
   where
@@ -283,3 +363,5 @@ of cons's. We can achieve that slightly indirectly by
 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
+
+
index 63e5cbe..45fbf07 100644 (file)
@@ -40,7 +40,7 @@ import TysWiredIn
 import BasicTypes
 import PrelNames
 import Outputable
-
+import Bag
 import VarSet
 import SrcLoc
 
@@ -1023,20 +1023,20 @@ See comments in HsUtils for why the other version does not include
 these bindings.
 
 \begin{code}
-collectPatBinders :: OutputableBndr a => LPat a -> [a]
+collectPatBinders :: LPat Id -> [Id]
 collectPatBinders pat = collectl pat []
 
-collectPatsBinders :: OutputableBndr a => [LPat a] -> [a]
+collectPatsBinders :: [LPat Id] -> [Id]
 collectPatsBinders pats = foldr collectl [] pats
 
 ---------------------
-collectl :: OutputableBndr a => LPat a -> [a] -> [a]
+collectl :: LPat Id -> [Id] -> [Id]
 -- See Note [Dictionary binders in ConPatOut]
 collectl (L _ pat) bndrs
   = go pat
   where
     go (VarPat var)               = var : bndrs
-    go (VarPatOut var bs)         = var : collectHsBindsBinders bs
+    go (VarPatOut var bs)         = var : collectEvBinders bs
                                     ++ bndrs
     go (WildPat _)                = bndrs
     go (LazyPat pat)              = collectl pat bndrs
@@ -1050,7 +1050,7 @@ collectl (L _ pat) bndrs
 
     go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps, pat_binds=ds}) =
-                                    collectHsBindsBinders ds
+                                    collectEvBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
     go (LitPat _)                 = bndrs
     go (NPat _ _ _)               = bndrs
@@ -1062,4 +1062,13 @@ collectl (L _ pat) bndrs
     go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
     go (ViewPat _ pat _)          = collectl pat bndrs
     go p@(QuasiQuotePat {})       = pprPanic "collectl/go" (ppr p)
+
+collectEvBinders :: TcEvBinds -> [Id]
+collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
+
+add_ev_bndr :: EvBind -> [Id] -> [Id]
+add_ev_bndr (EvBind b _) bs | isId b    = b:bs
+                            | otherwise = bs
+  -- A worry: what about coercion variable binders??
 \end{code}
index 2c6f361..c886c8e 100644 (file)
@@ -11,8 +11,8 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
-                dsCoercion,
-                AutoScc(..)
+                dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
+                DsEvBind(..), AutoScc(..)
   ) where
 
 #include "HsVersions.h"
@@ -32,30 +32,34 @@ import CoreUtils
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
+import Digraph
 
 import TcType
+import Type
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
 import Id
+import TyCon   ( tyConDataCons )
+import Class
+import DataCon ( dataConRepType )
 import Name    ( localiseName )
 import MkId    ( seqId )
-import Var     ( Var, TyVar, tyVarKind )
-import IdInfo  ( vanillaIdInfo )
+import Var
 import VarSet
 import Rules
 import VarEnv
 import Outputable
 import SrcLoc
 import Maybes
+import OrdList
 import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString
-import StaticFlags     ( opt_DsMultiTyVar )
-import Util            ( count, lengthExceeds )
+-- import StaticFlags  ( opt_DsMultiTyVar )
+import Util
 
 import MonadUtils
-import Control.Monad
 \end{code}
 
 %************************************************************************
@@ -66,31 +70,27 @@ import Control.Monad
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
+                                  ; return (fromOL binds') }
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsLHsBinds binds = ds_lhs_binds NoSccs binds
-
+dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
+                      ; return (fromOL binds') }
 
 ------------------------
-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 
         -- scc annotation policy (see below)
-ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
+ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
+                                 ; return (foldBag appOL id nilOL ds_bs) }
 
-dsLHsBind :: AutoScc
-        -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
-        -> LHsBind Id
-        -> DsM [(Id,CoreExpr)] -- Result
-dsLHsBind auto_scc rest (L loc bind)
-  = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
+dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind auto_scc (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind auto_scc bind
 
-dsHsBind :: AutoScc
-        -> [(Id,CoreExpr)]     -- Put this on the end (avoid quadratic append)
-        -> HsBind Id
-        -> DsM [(Id,CoreExpr)] -- Result
+dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
 
-dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
   = do { core_expr <- dsLExpr expr
 
                -- Dictionary bindings are always VarBinds,
@@ -99,25 +99,30 @@ dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_reg
        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
                   | otherwise         = var
 
-       ; return ((var', core_expr') : rest) }
+       ; return (unitOL (var', core_expr')) }
 
-dsHsBind _ rest 
-        (FunBind { fun_id = L _ fun, fun_matches = matches, 
-                   fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) 
+dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches 
+                   , fun_co_fn = co_fn, fun_tick = tick 
+                    , fun_infix = inf }) 
  = do  { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
        ; body'    <- mkOptTickBox tick body
-       ; wrap_fn' <- dsCoercion co_fn 
-       ; return ((fun, wrap_fn' (mkLams args body')) : rest) }
+       ; wrap_fn' <- dsHsWrapper co_fn 
+       ; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
 
-dsHsBind _ rest 
-        (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
   = do { body_expr <- dsGuarded grhss ty
        ; sel_binds <- mkSelectorBinds pat body_expr
-       ; return (sel_binds ++ rest) }
+       ; return (toOL sel_binds) }
 
-dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
-  = do { core_prs <- ds_lhs_binds NoSccs binds
-       ; let env = mkABEnv exports
+{-
+dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
+                                   , abs_exports = exports, abs_ev_binds = ev_binds
+                                   , abs_binds = binds })
+  = do { bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
+
+       ; let core_prs = addEvPairs ds_ev_binds bind_prs
+              env = mkABEnv exports
              do_one (lcl_id, rhs) 
                | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
                = do { let rhs' = addAutoScc auto_scc gbl_id rhs
@@ -137,13 +142,19 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
                -- because we can rely on the enclosing dsBind to wrap in Rec
 
 
-dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
+dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
+                                        , abs_exports = exports, abs_ev_binds = ev_binds
+                                        , abs_binds = binds })
   | opt_DsMultiTyVar   -- This (static) debug flag just lets us
                        -- switch on and off this optimisation to
                        -- see if it has any impact; it is on by default
+  , allOL isLazyEvBind ev_binds
   =    -- Note [Abstracting over tyvars only]
-    do { core_prs <- ds_lhs_binds NoSccs binds
-       ; let arby_env = mkArbitraryTypeEnv tyvars exports
+    do { bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
+
+       ; let core_prs = addEvPairs ds_ev_binds bind_prs
+              arby_env = mkArbitraryTypeEnv tyvars exports
              bndrs = mkVarSet (map fst core_prs)
 
              add_lets | core_prs `lengthExceeds` 10 = add_some
@@ -179,21 +190,25 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
                                                  
        ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
        ; return (concat core_prs' ++ rest) }
+-}
 
-       -- Another common case: one exported variable
+       -- A common case: one exported variable
        -- Non-recursive bindings come through this way
        -- So do self-recursive bindings, and recursive bindings
        -- that have been chopped up with type signatures
-dsHsBind auto_scc rest
-     (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+                                   , abs_exports = [(tyvars, global, local, prags)]
+                                   , abs_ev_binds = ev_binds, abs_binds = binds })
   = ASSERT( all (`elem` tyvars) all_tyvars )
-    do { core_prs <- ds_lhs_binds NoSccs binds
+    do { bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
 
-       ; let   -- Always treat the binds as recursive, because the 
-               -- typechecker makes rather mixed-up dictionary bindings
-               core_bind = Rec core_prs
+       ; let   core_bind = Rec (fromOL bind_prs)
                rhs       = addAutoScc auto_scc global $
-                           mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+                           mkLams tyvars $ mkLams dicts $ 
+                           wrapDsEvBinds ds_ev_binds $
+                            Let core_bind $
+                            Var local
     
        ; (spec_binds, rules) <- dsSpecs global rhs prags
 
@@ -201,22 +216,27 @@ dsHsBind auto_scc rest
                main_bind = makeCorePair global' (isDefaultMethod prags)
                                          (dictArity dicts) rhs 
     
-       ; return (main_bind : spec_binds ++ rest) }
+       ; return (main_bind `consOL` spec_binds) }
 
-dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
-  = do { core_prs <- ds_lhs_binds NoSccs binds
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+                            , abs_exports = exports, abs_ev_binds = ev_binds
+                                   , abs_binds = binds })
+  = do { bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
        ; let env = mkABEnv exports
              do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
                                  = (lcl_id, addAutoScc auto_scc gbl_id rhs)
                                  | otherwise = (lcl_id,rhs)
               
-               -- Rec because of mixed-up dictionary bindings
-             core_bind = Rec (map do_one core_prs)
+             core_bind = Rec (map do_one (fromOL bind_prs))
+               -- Monomorphic recursion possible, hence Rec
 
              tup_expr     = mkBigCoreVarTup locals
              tup_ty       = exprType tup_expr
              poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
-                            Let core_bind tup_expr
+                            wrapDsEvBinds ds_ev_binds $
+                            Let core_bind $
+                            tup_expr
              locals       = [local | (_, _, local, _) <- exports]
              local_tys    = map idType locals
 
@@ -237,7 +257,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
                                                      (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
                                                      spec_prags
                     ; let global' = addIdSpecialisations global rules
-                    ; return ((global', rhs) : spec_binds) }
+                    ; return ((global', rhs) `consOL` spec_binds) }
                where
                  mk_ty_arg all_tyvar
                        | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
@@ -246,9 +266,89 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
        ; export_binds_s <- mapM mk_bind (exports `zip` [0..])
             -- Don't scc (auto-)annotate the tuple itself.
 
-       ; return ((poly_tup_id, poly_tup_rhs) : 
-                   (concat export_binds_s ++ rest)) }
+       ; return ((poly_tup_id, poly_tup_rhs) `consOL` 
+                   concatOL export_binds_s) }
+
+--------------------------------------
+data DsEvBind 
+  = LetEvBind          -- Dictionary or coercion
+      CoreBind         -- recursive or non-recursive
 
+  | CaseEvBind         -- Coercion binding by superclass selection
+                       -- Desugars to case d of d { K _ g _ _ _ -> ... }                       
+      DictId              -- b   The dictionary
+      AltCon              -- K   Its constructor
+      [CoreBndr]          -- _ g _ _ _   The binders in the alternative
+
+wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
+wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
+  where
+    body_ty = exprType body
+    wrap_one (LetEvBind b)       body = Let b body
+    wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
+
+dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
+dsEvBinds bs = return (map dsEvGroup sccs)
+  where
+    sccs :: [SCC EvBind]
+    sccs = stronglyConnCompFromEdgedVertices edges
+
+    edges :: [(EvBind, EvVar, [EvVar])]
+    edges = foldrBag ((:) . mk_node) [] bs 
+
+    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
+    mk_node b@(EvBind var term) = (b, var, free_vars_of term)
+
+    free_vars_of :: EvTerm -> [EvVar]
+    free_vars_of (EvId v)           = [v]
+    free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
+    free_vars_of (EvDFunApp _ _ vs) = vs
+    free_vars_of (EvSuperClass d _) = [d]
+
+dsEvGroup :: SCC EvBind -> DsEvBind
+dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
+  | isCoVar co_var      -- An equality superclass
+  = ASSERT( null other_data_cons )
+    CaseEvBind dict (DataAlt data_con) bndrs
+  where
+    (cls, tys) = getClassPredTys (evVarPred dict)
+    (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
+    (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
+    (arg_tys, _) = splitFunTys rho
+    bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
+                   ++ map mkWildValBinder arg_tys
+    mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
+                                      co_var
+                        | otherwise = mkWildEvBinder p
+    
+dsEvGroup (AcyclicSCC (EvBind v r))
+  = LetEvBind (NonRec v (dsEvTerm r))
+
+dsEvGroup (CyclicSCC bs)
+  = LetEvBind (Rec (map ds_pair bs))
+  where
+    ds_pair (EvBind v r) = (v, dsEvTerm r)
+
+dsEvTerm :: EvTerm -> CoreExpr
+dsEvTerm (EvId v)                       = Var v
+dsEvTerm (EvCast v co)                  = Cast (Var v) co 
+dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
+dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvSuperClass d n)
+  = ASSERT( isClassPred (classSCTheta cls !! n) )
+           -- We can only select *dictionary* superclasses
+           -- in terms.  Equality superclasses are dealt with
+           -- in dsEvGroup, where they can generate a case expression
+    Var sc_sel_id `mkTyApps` tys `App` Var d
+  where
+    sc_sel_id  = classSCSelId cls n    -- Zero-indexed
+    (cls, tys) = getClassPredTys (evVarPred d)    
+    
 ------------------------
 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
 makeCorePair gbl_id is_default_method dict_arity rhs
@@ -445,34 +545,36 @@ Note that
 dsSpecs :: Id          -- The polymorphic Id
         -> CoreExpr     -- Its rhs
         -> TcSpecPrags
-        -> DsM ( [(Id,CoreExpr)]       -- Binding for specialised Ids
+        -> DsM ( OrdList (Id,CoreExpr)         -- Binding for specialised Ids
               , [CoreRule] )           -- Rules for the Global Ids
 -- See Note [Implementing SPECIALISE pragmas]
 dsSpecs poly_id poly_rhs prags
   = case prags of
-      IsDefaultMethod      -> return ([], [])
+      IsDefaultMethod      -> return (nilOL, [])
       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
                           ; let (spec_binds_s, rules) = unzip pairs
-                          ; return (concat spec_binds_s, rules) }
+                          ; return (concatOL spec_binds_s, rules) }
  where 
-    spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+    spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
     spec_one (L loc (SpecPrag spec_co spec_inl))
       = putSrcSpanDs loc $ 
         do { let poly_name = idName poly_id
           ; spec_name <- newLocalName poly_name
-          ; wrap_fn   <- dsCoercion spec_co
-           ; let ds_spec_expr = wrap_fn (Var poly_id)
-                 spec_ty = exprType ds_spec_expr
-          ; case decomposeRuleLhs ds_spec_expr of {
+          ; wrap_fn   <- dsHsWrapper spec_co
+           ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
+                 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
+          ; case decomposeRuleLhs ds_lhs of {
               Nothing -> do { warnDs (decomp_msg spec_co)
                              ; return Nothing } ;
 
-              Just (bndrs, _fn, args) ->
+              Just (_fn, args) ->
 
           -- Check for dead binders: Note [Unused spec binders]
-            case filter isDeadBinder bndrs of {
-               bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
-                  | otherwise -> do
+             let arg_fvs = exprsFreeVars args
+                 bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
+            in if not (null bad_bndrs)
+                then do { warnDs (dead_msg bad_bndrs); return Nothing } 
+               else do
 
           { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
 
@@ -486,7 +588,7 @@ dsSpecs poly_id poly_rhs prags
 
                 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
                                             -- See Note [Constant rule dicts]
-                                   | d <- varSetElems (exprFreeVars ds_spec_expr)
+                                   | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
                                    , isDictId d]
 
                 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
@@ -497,8 +599,8 @@ dsSpecs poly_id poly_rhs prags
                  spec_rhs  = wrap_fn poly_rhs
                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
-           ; return (Just (spec_pair : unf_pairs, rule))
-           } } } }
+           ; return (Just (spec_pair `consOL` unf_pairs, rule))
+           } } }
 
     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
                                 <+> ptext (sLit "in specialied type:"),
@@ -512,14 +614,15 @@ dsSpecs poly_id poly_rhs prags
             
 
 specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
-              -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+              -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
-       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
+       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
 specUnfolding _ _ _
-  = return (noUnfolding, [])
+  = return (noUnfolding, nilOL)
 
+{-
 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
 -- If any of the tyvars is missing from any of the lists in 
 -- the second arg, return a binding in the result
@@ -535,6 +638,7 @@ mkArbitraryTypeEnv tyvars exports
                                      , not (tv `elemVarEnv` env)]
 
     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
+-}
 
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
@@ -587,37 +691,51 @@ as the old one, but with an Internal name and no IdInfo.
 %************************************************************************
 
 \begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
 -- Take apart the LHS of a RULE.  It's suuposed to look like
 --     /\a. f a Int dOrdInt
 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 -- That is, the RULE binders are lambda-bound
 -- Returns Nothing if the LHS isn't of the expected shape
 decomposeRuleLhs lhs 
-  = case collectArgs body of
-        (Var fn, args) -> Just (bndrs, fn, args)
+  =  -- Note [Simplifying the left-hand side of a RULE]
+    case collectArgs (simpleOptExpr lhs) of
+        (Var fn, args) -> Just (fn, args)
 
         (Case scrut bndr ty [(DEFAULT, _, body)], args)
                | isDeadBinder bndr     -- Note [Matching seqId]
-               -> Just (bndrs, seqId, args' ++ args)
+               -> Just (seqId, args' ++ args)
                where
                   args' = [Type (idType bndr), Type ty, scrut, body]
           
        _other -> Nothing       -- Unexpected shape
-  where
-    (bndrs, body) = collectBinders (simpleOptExpr lhs)
-       -- simpleOptExpr occurrence-analyses and simplifies the lhs
-       -- and thereby
-       -- (a) identifies unused binders: Note [Unused spec binders]
-       -- (b) sorts dict bindings into NonRecs 
-       --      so they can be inlined by 'decomp'
-       -- (c) substitute trivial lets so that they don't get in the way
-       --     Note that we substitute the function too; we might 
-       --     have this as a LHS:  let f71 = M.f Int in f71
-        -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
-       --     dictionary expressions that we might have to match
 \end{code}
 
+Note [Simplifying the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+simpleOptExpr occurrence-analyses and simplifies the lhs
+and thereby
+(a) sorts dict bindings into NonRecs and inlines them
+(b) substitute trivial lets so that they don't get in the way
+    Note that we substitute the function too; we might 
+    have this as a LHS:  let f71 = M.f Int in f71
+(c) does eta reduction
+
+For (c) consider the fold/build rule, which without simplification
+looked like:
+       fold k z (build (/\a. g a))  ==>  ...
+This doesn't match unless you do eta reduction on the build argument.
+Similarly for a LHS like
+       augment g (build h) 
+we do not want to get
+       augment (\a. g a) (build h)
+otherwise we don't match when given an argument like
+       augment (\a. h a a) (build h)
+
+NB: tcSimplifyRuleLhs is very careful not to generate complicated
+    dictionary expressions that we might have to match
+
+
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
@@ -679,19 +797,16 @@ addDictScc _ rhs = return rhs
 
 
 \begin{code}
-dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
-dsCoercion WpHole           = return (\e -> e)
-dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 
-                                  ; k2 <- dsCoercion c2
-                                  ; return (k1 . k2) }
-dsCoercion (WpCast co)       = return (\e -> Cast e co) 
-dsCoercion (WpLam id)        = return (\e -> Lam id e) 
-dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e) 
-dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
-                             = return (\e -> App e (Type (mkTyVarTy v)))
-                            | otherwise
-                             = return (\e -> App e (Var v))
-dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
-dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
-                                 ; return (\e -> Let (Rec prs) e) }
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole           = return (\e -> e)
+dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
+dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+                                   ; return (wrapDsEvBinds ds_ev_binds) }
+dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
+                                   ; k2 <- dsHsWrapper c2
+                                   ; return (k1 . k2) }
+dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
+dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
+dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
+dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
 \end{code}
index ef69b47..9df432b 100644 (file)
@@ -86,9 +86,9 @@ dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
 
 -------------------------
 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ip_binds dict_binds) body
-  = do { prs <- dsLHsBinds dict_binds
-       ; let inner = Let (Rec prs) body
+dsIPBinds (IPBinds ip_binds ev_binds) body
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; let inner = wrapDsEvBinds ds_ev_binds body
                -- The dict bindings may not be in 
                -- dependency order; hence Rec
        ; foldrM ds_ip_bind inner ip_binds }
@@ -104,50 +104,18 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 -- a tuple and doing selections.
 -- Silently ignore INLINE and SPECIALISE pragmas...
 ds_val_bind (NonRecursive, hsbinds) body
-  | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
-    (L loc bind : null_binds) <- bagToList binds,
-    isBangHsBind bind
-    || isUnboxedTupleBind bind
-    || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
-  = let
-      body_w_exports                 = foldr bind_export body exports
-      bind_export (tvs, g, l, _) body = ASSERT( null tvs )
-                                       bindNonRec g (Var l) body
-    in
-    ASSERT (null null_binds)
+  | [L loc bind] <- bagToList hsbinds,
        -- Non-recursive, non-overloaded bindings only come in ones
        -- ToDo: in some bizarre case it's conceivable that there
        --       could be dict binds in the 'binds'.  (See the notes
        --       below.  Then pattern-match would fail.  Urk.)
-    putSrcSpanDs loc   $
-    case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, 
-               fun_tick = tick, fun_infix = inf }
-        -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
-              MASSERT( null args ) -- Functions aren't lifted
-              MASSERT( isIdHsWrapper co_fn )
-              rhs' <- mkOptTickBox tick rhs
-              return (bindNonRec fun rhs' body_w_exports)
-
-      PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
-       ->      -- let C x# y# = rhs in body
-               -- ==> case rhs of C x# y# -> body
-          putSrcSpanDs loc                     $
-           do { rhs <- dsGuarded grhss ty
-              ; let upat = unLoc pat
-                    eqn = EqnInfo { eqn_pats = [upat], 
-                                    eqn_rhs = cantFailMatchResult body_w_exports }
-              ; var    <- selectMatchVar upat
-              ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
-              ; return (scrungleMatch var rhs result) }
-
-      _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
-
+    strictMatchOnly bind
+  = putSrcSpanDs loc (dsStrictBind bind body)
 
 -- Ordinary case for bindings; none should be unlifted
 ds_val_bind (_is_rec, binds) body
   = do { prs <- dsLHsBinds binds
-       ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+       ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
          case prs of
             [] -> return body
             _  -> return (Let (Rec prs) body) }
@@ -162,9 +130,53 @@ ds_val_bind (_is_rec, binds) body
        -- NB The previous case dealt with unlifted bindings, so we
        --    only have to deal with lifted ones now; so Rec is ok
 
-isUnboxedTupleBind :: HsBind Id -> Bool
-isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
-isUnboxedTupleBind _                             = False
+------------------
+dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
+dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+               , abs_exports = exports
+               , abs_ev_binds = ev_binds
+               , abs_binds = binds }) body
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; let body1 = foldr bind_export body exports
+             bind_export (_, g, l, _) b = bindNonRec g (Var l) b
+       ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
+                            body1 binds 
+       ; return (wrapDsEvBinds ds_ev_binds body2) }
+
+dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn 
+                     , fun_tick = tick, fun_infix = inf }) body
+               -- Can't be a bang pattern (that looks like a PatBind)
+               -- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
+       ; MASSERT( null args ) -- Functions aren't lifted
+       ; MASSERT( isIdHsWrapper co_fn )
+       ; rhs' <- mkOptTickBox tick rhs
+       ; return (bindNonRec fun rhs' body) }
+
+dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+  =    -- let C x# y# = rhs in body
+       -- ==> case rhs of C x# y# -> body
+    do { rhs <- dsGuarded grhss ty
+       ; let upat = unLoc pat
+             eqn = EqnInfo { eqn_pats = [upat], 
+                             eqn_rhs = cantFailMatchResult body }
+       ; var    <- selectMatchVar upat
+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+       ; return (scrungleMatch var rhs result) }
+
+dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+
+----------------------
+strictMatchOnly :: HsBind Id -> Bool
+strictMatchOnly (AbsBinds { abs_binds = binds })
+  = anyBag (strictMatchOnly . unLoc) binds
+strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
+  =  isUnboxedTupleType ty 
+  || isBangLPat lpat   
+  || any (isUnLiftedType . idType) (collectPatBinders lpat)
+strictMatchOnly (FunBind { fun_id = L _ id })
+  = isUnLiftedType (idType id)
+strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 
 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 -- Returns something like (let var = scrut in body)
@@ -211,7 +223,7 @@ dsExpr (HsVar var)                = return (Var var)
 dsExpr (HsIPVar ip)                  = return (Var (ipNameName ip))
 dsExpr (HsLit lit)                   = dsLit lit
 dsExpr (HsOverLit lit)               = dsOverLit lit
-dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsCoercion co_fn
+dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsHsWrapper co_fn
                                    ; e' <- dsExpr e
                                    ; return (co_fn' e') }
 
@@ -289,9 +301,6 @@ dsExpr (HsSCC cc expr) = do
     mod_name <- getModuleDs
     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
 
-
--- hdaume: core annotation
-
 dsExpr (HsCoreAnn fs expr)
   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 
@@ -326,8 +335,10 @@ dsExpr (HsDo DoExpr stmts body result_ty)
 dsExpr (HsDo GhciStmt stmts body result_ty)
   = dsDo stmts body result_ty
 
-dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
-  = dsMDo tbl stmts body result_ty
+dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
+  = do { (meth_binds, tbl') <- dsSyntaxTable tbl
+       ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
+       ; return (mkLets meth_binds core_expr) }
 
 dsExpr (HsDo PArrComp stmts body result_ty)
   =    -- Special case for array comprehensions
@@ -523,8 +534,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
                 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
                        -- Reconstruct with the WrapId so that unpacking happens
-                wrap = mkWpApps theta_vars `WpCompose` 
-                       mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
+                wrap = mkWpEvVarApps theta_vars          `WpCompose` 
+                       mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
                        mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
                                       , isNothing (lookupTyVar wrap_subst tv) ]
                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
@@ -543,7 +554,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                 
                 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
                                         , pat_dicts = eqs_vars ++ theta_vars
-                                        , pat_binds = emptyLHsBinds 
+                                        , pat_binds = emptyTcEvBinds
                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
                                         , pat_ty = in_ty }
           ; return (mkSimpleMatch [pat] wrapped_rhs) }
@@ -733,9 +744,10 @@ dsDo stmts body result_ty
     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts 
+                    , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts 
       = ASSERT( length rec_ids > 0 )
-        goL (new_bind_stmt : let_stmt : stmts)
+        ASSERT( isEmptyTcEvBinds _ev_binds )   -- No method binds
+        goL (new_bind_stmt : stmts)
       where
         -- returnE <- dsExpr return_id
         -- mfixE <- dsExpr mfix_id
@@ -743,8 +755,6 @@ dsDo stmts body result_ty
                                          bind_op 
                                             noSyntaxExpr  -- Tuple cannot fail
 
-        let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
@@ -782,13 +792,14 @@ We turn (RecStmt [v1,..vn] stmts) into:
                                      return (v1,..vn))
 
 \begin{code}
-dsMDo  :: PostTcTable
+dsMDo  :: HsStmtContext Name
+        -> [(Name,Id)]
        -> [LStmt Id]
        -> LHsExpr Id
        -> Type                 -- Type of the whole expression
        -> DsM CoreExpr
 
-dsMDo tbl stmts body result_ty
+dsMDo ctxt tbl stmts body result_ty
   = goL stmts
   where
     goL [] = dsLExpr body
@@ -800,7 +811,6 @@ dsMDo tbl stmts body result_ty
     bind_id   = lookupEvidence tbl bindMName
     then_id   = lookupEvidence tbl thenMName
     fail_id   = lookupEvidence tbl failMName
-    ctxt      = MDoExpr tbl
 
     go _ (LetStmt binds) stmts
       = do { rest <- goL stmts
@@ -825,15 +835,16 @@ dsMDo tbl stmts body result_ty
           ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
                                             rhs', Lam var match_code]) }
     
-    go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
+    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+                    , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets 
+                    , recS_dicts = _ev_binds }) stmts
       = ASSERT( length rec_ids > 0 )
         ASSERT( length rec_ids == length rec_rets )
+        ASSERT( isEmptyTcEvBinds _ev_binds )
         pprTrace "dsMDo" (ppr later_ids) $
-        goL (new_bind_stmt : let_stmt : stmts)
+        goL (new_bind_stmt : stmts)
       where
         new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
-       let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
        
                -- Remove the later_ids that appear (without fancy coercions) 
                -- in rec_rets, because there's no need to knot-tie them separately
index 25366fa..4c05f5e 100644 (file)
@@ -221,7 +221,7 @@ wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
 wrapBind new old body  -- Can deal with term variables *or* type variables
   | new==old    = body
-  | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
+  | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
   | otherwise   = Let (NonRec new (Var old))         body
 
 seqVar :: Var -> CoreExpr -> CoreExpr
@@ -475,7 +475,7 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   where
     case_bndr = case arg1 of
                    Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
-                   _                     -> mkWildBinder ty1
+                   _                     -> mkWildValBinder ty1
 
 mkCoreAppDs fun arg = mkCoreApp fun arg         -- The rest is done in MkCore
 
@@ -550,8 +550,7 @@ mkSelectorBinds pat val_expr
       error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
       tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
       tuple_var <- newSysLocalDs tuple_ty
-      let
-          mk_tup_bind binder
+      let mk_tup_bind binder
             = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
       return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
   where
index d676911..e148cf7 100644 (file)
@@ -346,7 +346,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
   = do { let CoPat co pat _ = firstPat eqn1
        ; var' <- newUniqueId var (hsPatType pat)
        ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
-       ; co' <- dsCoercion co
+       ; co' <- dsHsWrapper co
         ; let rhs' = co' (Var var)
        ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
 
@@ -464,8 +464,8 @@ tidy1 v (VarPat var)
   = return (wrapBind var v, WildPat (idType var)) 
 
 tidy1 v (VarPatOut var binds)
-  = do { prs <- dsLHsBinds binds
-       ; return (wrapBind var v . mkCoreLet (Rec prs),
+  = do { ds_ev_binds <- dsTcEvBinds binds
+       ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
                  WildPat (idType var)) }
 
        -- case v of { x@p -> mr[] }
@@ -875,7 +875,7 @@ viewLExprEq (e1,_) (e2,_) =
         wrap WpHole WpHole = True
         wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
         wrap (WpCast c)  (WpCast c')  = tcEqType c c'
-        wrap (WpApp d)   (WpApp d')   = d == d'
+        wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq"
         wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
         -- Enhancement: could implement equality for more wrappers
         --   if it seems useful (lams and lets)
index 9ec7f35..03fa325 100644 (file)
@@ -23,8 +23,6 @@ import HsSyn
 import DsBinds
 import DataCon
 import TcType
-import CoreSyn
-import MkCore
 import DsMonad
 import DsUtils
 import Util    ( all2, takeList, zipEqual )
@@ -140,10 +138,10 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
     shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, 
                                                   pat_binds = bind, pat_args = args
                                        } : pats }))
-      = do { prs <- dsLHsBinds bind
+      = do { ds_ev_binds <- dsTcEvBinds bind
           ; return (wrapBinds (tvs `zip` tvs1) 
                    . wrapBinds (ds  `zip` dicts1)
-                   . mkCoreLet (Rec prs),
+                   . wrapDsEvBinds ds_ev_binds,
                    eqn { eqn_pats = conArgPats arg_tys args ++ pats }) }
 
     -- Choose the right arg_vars in the right order for this group
index 01e7b07..d2a199b 100644 (file)
@@ -408,11 +408,14 @@ Library
         TcRnTypes
         TcRules
         TcSimplify
+        TcErrors
         TcTyClsDecls
         TcTyDecls
-        TcTyFuns
         TcType
         TcUnify
+        TcInteract
+        TcCanonical
+        TcSMonad
         Class
         Coercion
         FamInstEnv
index 5d1bd27..90931cc 100644 (file)
@@ -250,7 +250,7 @@ schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -834,7 +834,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
             rhs_code <- schemeE (d_alts+size) s p' rhs
              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
           where
-            real_bndrs = filter (not.isTyVar) bndrs
+            real_bndrs = filter (not.isTyCoVar) bndrs
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _) 
@@ -1146,6 +1146,8 @@ maybe_getCCallReturnRep fn_ty
                                   -- if it was, it would be impossible 
                                   -- to create a valid return value 
                                   -- placeholder on the stack
+
+         blargh :: a -- Used at more than one type
          blargh = pprPanic "maybe_getCCallReturn: can't handle:" 
                            (pprType fn_ty)
      in 
@@ -1455,7 +1457,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 -- whereas value lambdas cannot; that is why they are nuked here
 bcView (AnnNote _ (_,e))            = Just e
 bcView (AnnCast (_,e) _)            = Just e
-bcView (AnnLam v (_,e)) | isTyVar v  = Just e
+bcView (AnnLam v (_,e)) | isTyCoVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
 bcView _                             = Nothing
 
index 45cbdc0..d53d247 100644 (file)
@@ -633,6 +633,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
             text "module" <+> ppr mod <+> 
             text "cannot be linked; it is only available as a boot module")))
 
+    no_obj :: Outputable a => a -> IO b
     no_obj mod = dieWith span $
                     ptext (sLit "cannot find object file for module ") <> 
                        quotes (ppr mod) $$
@@ -657,7 +658,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
                -- ...and then find the linkable for it
               mb_lnk <- findObjectLinkableMaybe mod loc ;
               case mb_lnk of {
-                 Nothing -> no_obj mod ;
+                 Nothing  -> no_obj mod ;
                  Just lnk -> adjust_linkable lnk
              }}
 
index a23d355..fa167e3 100644 (file)
@@ -569,13 +569,13 @@ liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
+newVar = liftTcM . newFlexiTyVarTy
 
 -- | Returns the instantiated type scheme ty', and the substitution sigma 
 --   such that sigma(ty') = ty 
 instScheme :: Type -> TR (TcType, TvSubst)
 instScheme ty = liftTcM$ do
-   (tvs, _, _)      <- tcInstType return ty
+   (tvs, _, _)  <- tcInstType return ty
    (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
@@ -590,7 +590,7 @@ addConstraint actual expected = do
     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
                                     text "with", ppr expected])
               (congruenceNewtypes actual expected >>=
-                           (getLIE . uncurry boxyUnify) >> return ())
+                           (getConstraints . uncurry unifyType) >> return ())
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
@@ -861,7 +861,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
     (ty_tvs,  _, _)   <- tcInstType return ty
     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
-    _ <- getLIE(boxyUnify rtti_ty' ty')
+    _ <- getConstraints(unifyType rtti_ty' ty')
     tvs1_contents     <- zonkTcTyVars ty_tvs'
     let subst = (uncurry zipTopTvSubst . unzip)
                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
@@ -1101,7 +1101,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                         text " in presence of newtype evidence " <> ppr new_tycon)
                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
-               _ <- liftTcM (boxyUnify ty (repType ty'))
+               _ <- liftTcM (unifyType ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
                return ty'
 
index 5709e58..f8afd26 100644 (file)
@@ -32,10 +32,13 @@ import BasicTypes
 import Outputable      
 import SrcLoc
 import Util
+import VarEnv
 import Var
 import Bag
+import Unique
 import FastString
 
+import Data.IORef( IORef )
 import Data.Data hiding ( Fixity )
 \end{code}
 
@@ -77,10 +80,9 @@ data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
        [LSig Name]
   deriving (Data, Typeable)
 
-type LHsBinds id  = Bag (LHsBind id)
-type DictBinds id = LHsBinds id                -- Used for dictionary or method bindings
-type LHsBind  id  = Located (HsBind id)
-type HsBind id = HsBindLR id id
+type LHsBinds id = Bag (LHsBind id)
+type LHsBind  id = Located (HsBind id)
+type HsBind id   = HsBindLR id id
 
 type LHsBindLR idL idR = Located (HsBindLR idL idR)
 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
@@ -123,7 +125,7 @@ data HsBindLR idL idR
                                -- Before renaming, and after typechecking, 
                                -- the field is unused; it's just an error thunk
 
-        fun_tick :: Maybe (Int,[idR])   -- ^ This is the (optional) module-local tick number.
+        fun_tick :: Maybe (Int,[Id])   -- ^ This is the (optional) module-local tick number.
     }
 
   | PatBind {  -- The pattern is never a simple variable;
@@ -141,17 +143,17 @@ data HsBindLR idL idR
                                     -- (used for implication constraints only)
     }
 
-  | AbsBinds {                                 -- Binds abstraction; TRANSLATION
+  | AbsBinds {                         -- Binds abstraction; TRANSLATION
         abs_tvs     :: [TyVar],  
-       abs_dicts   :: [DictId],                -- Includes equality constraints
+       abs_ev_vars :: [EvVar],  -- Includes equality constraints
 
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil to have
        -- the right type
        abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],      -- (tvs, poly_id, mono_id, prags)
-       abs_binds   :: LHsBinds idL             -- The dictionary bindings and typechecked user bindings
-                                               -- mixed up together; you can tell the dict bindings because
-                                               -- they are all VarBinds
+
+        abs_ev_binds :: TcEvBinds,     -- Evidence bindings
+       abs_binds    :: LHsBinds idL   -- Typechecked user bindings
     }
   deriving (Data, Typeable)
        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
@@ -285,7 +287,7 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
                        Just t  -> text "-- tick id = " <> ppr t)
     $$  pprFunBind (unLoc fun) inf matches
 
-ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
+ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars, 
                         abs_exports = exports, abs_binds = val_binds })
   = sep [ptext (sLit "AbsBinds"),
         brackets (interpp'SP tyvars),
@@ -321,12 +323,12 @@ pprTicks pp_no_debug pp_when_debug
 data HsIPBinds id
   = IPBinds 
        [LIPBind id] 
-       (DictBinds id)  -- Only in typechecker output; binds 
+       TcEvBinds       -- Only in typechecker output; binds 
                        -- uses of the implicit parameters
   deriving (Data, Typeable)
 
 isEmptyIPBinds :: HsIPBinds id -> Bool
-isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
+isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
 
 type LIPBind id = Located (IPBind id)
 
@@ -339,7 +341,7 @@ data IPBind id
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
-                       $$ pprLHsBinds ds
+                       $$ ppr ds
 
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
@@ -359,65 +361,148 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 data HsWrapper
   = WpHole                     -- The identity coercion
 
-  | WpCompose HsWrapper HsWrapper      -- (\a1..an. []) `WpCompose` (\x1..xn. [])
-                               --      = (\a1..an \x1..xn. [])
+  | WpCompose HsWrapper HsWrapper      
+       -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]]
+       -- 
+       -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
+       -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
 
   | WpCast Coercion            -- A cast:  [] `cast` co
                                -- Guaranteed not the identity coercion
 
-  | WpApp Var                  -- [] d         the 'd' is a type-class dictionary or coercion variable
-
-  | WpTyApp Type               -- [] t         the 't' is a type or corecion
-                               --      ToDo: it'd be tidier if 't' was always a type (not coercion),
-                               --            but that is inconvenient in Inst.instCallDicts
+       -- Evidence abstraction and application
+        -- (both dictionaries and coercions)
+  | WpEvLam EvVar              -- \d. []       the 'd' is an evidence variable
+  | WpEvApp EvTerm             -- [] d         the 'd' is evidence for a constraint
 
-  | WpLam Var                  -- \d. []       the 'd' is a type-class dictionary or coercion variable
+       -- Type abstraction and application
   | WpTyLam TyVar              -- \a. []       the 'a' is a type variable (not coercion var)
+  | WpTyApp Type               -- [] t         the 't' is a type (not coercion)
+
 
-       -- Non-empty bindings, so that the identity coercion
-       -- is always exactly WpHole
-  | WpLet (LHsBinds Id)                -- let binds in []
-                               -- (would be nicer to be core bindings)
+  | WpLet TcEvBinds            -- Non-empty (or possibly non-empty) evidence bindings,
+                                -- so that the identity coercion is always exactly WpHole
   deriving (Data, Typeable)
 
-instance Outputable HsWrapper where 
-  ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
 
-pprHsWrapper :: SDoc -> HsWrapper -> SDoc
-pprHsWrapper it wrap = 
-    let 
-        help it WpHole            = it
-        help it (WpCompose f1 f2) = help (help it f2) f1
-        help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
-        help it (WpApp id)    = sep [it, nest 2 (ppr id)]
-        help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
-        help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
-        help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
-        help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
-    in
-      -- in debug mode, print the wrapper
-      -- otherwise just print what's inside
-      getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
+data TcEvBinds 
+  = TcEvBinds          -- Mutable evidence bindings
+       EvBindsVar      -- Mutable because they are updated "later"
+                       --    when an implication constraint is solved
+
+  | EvBinds            -- Immutable after zonking
+       (Bag EvBind)
+
+  deriving( Typeable )
+
+data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
+     -- The Unique is only for debug printing
+
+-----------------
+type EvBindMap = VarEnv EvBind
+
+emptyEvBindMap :: EvBindMap
+emptyEvBindMap = emptyVarEnv
+
+extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
+extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
+
+lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
+lookupEvBind = lookupVarEnv
+
+evBindMapBinds :: EvBindMap -> Bag EvBind
+evBindMapBinds = foldVarEnv consBag emptyBag
+
+-----------------
+instance Data TcEvBinds where
+  -- Placeholder; we can't travers into TcEvBinds
+  toConstr _   = abstractConstr "TcEvBinds"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "TcEvBinds"
+
+-- All evidence is bound by EvBinds; no side effects
+data EvBind = EvBind EvVar EvTerm
+
+data EvTerm
+  = EvId EvId                  -- Term-level variable-to-variable bindings 
+                               -- (no coercion variables! they come via EvCoercion)
+
+  | EvCoercion Coercion        -- Coercion bindings
+
+  | EvCast EvVar Coercion      -- d |> co
+
+  | EvDFunApp DFunId           -- Dictionary instance application
+       [Type] [EvVar]  
 
+  | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
+                               -- dictionaries, even though the former have no
+                              -- selector Id.  We count up from _0_ 
+                              
+  deriving( Data, Typeable)
+
+evVarTerm :: EvVar -> EvTerm
+evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+            | otherwise = EvId v
+\end{code}
+
+Note [EvBinds/EvTerm]
+~~~~~~~~~~~~~~~~~~~~~
+How evidence is created and updated. Bindings for dictionaries, 
+and coercions and implicit parameters are carried around in TcEvBinds
+which during constraint generation and simplification is always of the
+form (TcEvBinds ref). After constraint simplification is finished it 
+will be transformed to t an (EvBinds ev_bag). 
+
+Evidence for coercions *SHOULD* be filled in using the TcEvBinds 
+However, all EvVars that correspond to *wanted* coercion terms in 
+an EvBind must be mutable variables so that they can be readily 
+inlined (by zonking) after constraint simplification is finished.
+
+Conclusion: a new wanted coercion variable should be made mutable. 
+[Notice though that evidence variables that bind coercion terms 
+ from super classes will be "given" and hence rigid] 
+
+
+\begin{code}
+emptyTcEvBinds :: TcEvBinds
+emptyTcEvBinds = EvBinds emptyBag
+
+isEmptyTcEvBinds :: TcEvBinds -> Bool
+isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
+isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
 WpHole <.> c = c
 c <.> WpHole = c
 c1 <.> c2    = c1 `WpCompose` c2
 
 mkWpTyApps :: [Type] -> HsWrapper
-mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
+mkWpTyApps tys = mk_co_app_fn WpTyApp tys
+
+mkWpEvApps :: [EvTerm] -> HsWrapper
+mkWpEvApps args = mk_co_app_fn WpEvApp args
 
-mkWpApps :: [Var] -> HsWrapper
-mkWpApps ids = mk_co_fn WpApp (reverse ids)
+mkWpEvVarApps :: [EvVar] -> HsWrapper
+mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
 
 mkWpTyLams :: [TyVar] -> HsWrapper
-mkWpTyLams ids = mk_co_fn WpTyLam ids
+mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
 
 mkWpLams :: [Var] -> HsWrapper
-mkWpLams ids = mk_co_fn WpLam ids
+mkWpLams ids = mk_co_lam_fn WpEvLam ids
 
-mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-mk_co_fn f as = foldr (WpCompose . f) WpHole as
+mkWpLet :: TcEvBinds -> HsWrapper
+-- This no-op is a quite a common case
+mkWpLet (EvBinds b) | isEmptyBag b = WpHole
+mkWpLet ev_binds                   = WpLet ev_binds
+
+mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
+
+mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+-- For applications, the *first* argument must
+-- come *last* in the composition sequence
+mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
 
 idHsWrapper :: HsWrapper
 idHsWrapper = WpHole
@@ -427,6 +512,45 @@ isIdHsWrapper WpHole = True
 isIdHsWrapper _      = False
 \end{code}
 
+Pretty printing
+
+\begin{code}
+instance Outputable HsWrapper where 
+  ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
+
+pprHsWrapper :: SDoc -> HsWrapper -> SDoc
+-- In debug mode, print the wrapper
+-- otherwise just print what's inside
+pprHsWrapper it wrap
+  = getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
+  where
+    help it WpHole            = it
+    help it (WpCompose f1 f2) = help (help it f2) f1
+    help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
+    help it (WpEvApp id)  = sep [it, nest 2 (ppr id)]
+    help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
+    help it (WpEvLam id)  = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
+    help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
+    help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
+
+instance Outputable TcEvBinds where
+  ppr (TcEvBinds v) = ppr v
+  ppr (EvBinds bs)  = ptext (sLit "EvBinds") <> braces (ppr bs)
+
+instance Outputable EvBindsVar where
+  ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
+
+instance Outputable EvBind where
+  ppr (EvBind v e)   = ppr v <+> equals <+> ppr e
+
+instance Outputable EvTerm where
+  ppr (EvId v)          = ppr v
+  ppr (EvCast v co)     = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
+  ppr (EvCoercion co)    = ppr co
+  ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
+  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys
+                                             , ppr ts ]
+\end{code}
 
 %************************************************************************
 %*                                                                     *
index dff8ce7..d49afec 100644 (file)
@@ -232,6 +232,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
              ppr_ds deriv_decls,
             ppr_ds foreign_decls]
        where
+          ppr_ds :: Outputable a => [a] -> Maybe SDoc
          ppr_ds [] = Nothing
          ppr_ds ds = Just (vcat (map ppr ds))
 
@@ -636,6 +637,7 @@ instance OutputableBndr name
         top_matter    =     ptext (sLit "class") 
                        <+> pp_decl_head (unLoc context) lclas tyvars Nothing
                        <+> pprFundeps (map unLoc fds)
+        ppr_semi :: Outputable a => a -> SDoc
        ppr_semi decl = ppr decl <> semi
 
 pp_decl_head :: OutputableBndr name
index 84901ee..245631d 100644 (file)
@@ -48,7 +48,7 @@ type LHsExpr id = Located (HsExpr id)
 type PostTcExpr  = HsExpr Id
 -- | We use a PostTcTable where there are a bunch of pieces of evidence, more
 -- than is convenient to keep individually.
-type PostTcTable = [(Name, Id)]
+type PostTcTable = [(Name, PostTcExpr)]
 
 noPostTcExpr :: PostTcExpr
 noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
@@ -62,7 +62,7 @@ noPostTcTable = []
 --
 -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
 --      @(>>=)@, and then instantiated by the type checker with its type args
---      tec
+--      etc
 
 type SyntaxExpr id = HsExpr id
 
@@ -895,8 +895,8 @@ data StmtLR idL idR
                                      -- the returned thing has to be *monomorphic*, 
                                     -- so they may be type applications
 
-      , recS_dicts :: DictBinds idR  -- Method bindings of Ids bound by the
-                                     -- RecStmt, and used afterwards
+      , recS_dicts :: TcEvBinds    -- Method bindings of Ids bound by the
+                                   -- RecStmt, and used afterwards
       }
   deriving (Data, Typeable)
 \end{code}
@@ -1147,8 +1147,8 @@ pp_dotdot = ptext (sLit " .. ")
 \begin{code}
 data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
-  | CaseAlt                     -- Patterns and guards on a case alternative
   | LambdaExpr                  -- Patterns of a lambda
+  | CaseAlt                     -- Patterns and guards on a case alternative
   | ProcExpr                    -- Patterns of a proc
   | PatBindRhs                  -- Patterns in the *guards* of a pattern binding
   | RecUpd                      -- Record update [used only in DsExpr to
@@ -1198,16 +1198,25 @@ matchSeparator ThPatQuote   = panic "unused"
 
 \begin{code}
 pprMatchContext :: Outputable id => HsMatchContext id -> SDoc
-pprMatchContext (FunRhs fun _)    = ptext (sLit "the definition of")
-                                    <+> quotes (ppr fun)
-pprMatchContext CaseAlt           = ptext (sLit "a case alternative")
-pprMatchContext RecUpd            = ptext (sLit "a record-update construct")
-pprMatchContext ThPatQuote        = ptext (sLit "a Template Haskell pattern quotation")
-pprMatchContext PatBindRhs        = ptext (sLit "a pattern binding")
-pprMatchContext LambdaExpr        = ptext (sLit "a lambda abstraction")
-pprMatchContext ProcExpr          = ptext (sLit "an arrow abstraction")
-pprMatchContext (StmtCtxt ctxt)   = ptext (sLit "a pattern binding in")
-                                    $$ pprStmtContext ctxt
+pprMatchContext ctxt 
+  | want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt
+  | otherwise    = ptext (sLit "a")  <+> pprMatchContextNoun ctxt
+  where
+    want_an (FunRhs {}) = True -- Use "an" in front
+    want_an ProcExpr    = True
+    want_an _           = False
+                 
+pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
+pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for")
+                                      <+> quotes (ppr fun)
+pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative")
+pprMatchContextNoun RecUpd          = ptext (sLit "record-update construct")
+pprMatchContextNoun ThPatQuote      = ptext (sLit "Template Haskell pattern quotation")
+pprMatchContextNoun PatBindRhs      = ptext (sLit "pattern binding")
+pprMatchContextNoun LambdaExpr      = ptext (sLit "lambda abstraction")
+pprMatchContextNoun ProcExpr        = ptext (sLit "arrow abstraction")
+pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
+                                      $$ pprStmtContext ctxt
 
 pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
 pprStmtContext (ParStmtCtxt c)
index c025a8d..1bf0aa8 100644 (file)
@@ -20,11 +20,10 @@ module HsPat (
        HsConPatDetails, hsConPatArgs, 
        HsRecFields(..), HsRecField(..), hsRecFields,
 
-       mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
+       mkPrefixConPat, mkCharLitPat, mkNilPat, 
 
-       isBangHsBind, hsPatNeedsParens,
-       patsAreAllCons, isConPat, isSigPat, isWildPat,
-       patsAreAllLits, isLitPat, isIrrefutableHsPat,
+       isBangHsBind, isBangLPat, hsPatNeedsParens,
+       isIrrefutableHsPat,
 
        pprParendLPat
     ) where
@@ -37,7 +36,6 @@ import HsLit
 import HsTypes
 import BasicTypes
 -- others:
-import Coercion
 import PprCore         ( {- instance OutputableBndr TyVar -} )
 import TysWiredIn
 import Var
@@ -65,7 +63,7 @@ data Pat id
        -- support hsPatType :: Pat Id -> Type
 
   | VarPat     id                      -- Variable
-  | VarPatOut  id (DictBinds id)       -- Used only for overloaded Ids; the 
+  | VarPatOut  id TcEvBinds            -- Used only for overloaded Ids; the 
                                        -- bindings give its overloaded instances
   | LazyPat    (LPat id)               -- Lazy pattern
   | AsPat      (Located id) (LPat id)  -- As pattern
@@ -101,10 +99,10 @@ data Pat id
   | ConPatOut {
        pat_con   :: Located DataCon,
        pat_tvs   :: [TyVar],           -- Existentially bound type variables (tyvars only)
-       pat_dicts :: [id],              -- Ditto *coercion variables* and *dictionaries*
+       pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                        -- One reason for putting coercion variable here, I think,
                                        --      is to ensure their kinds are zonked
-       pat_binds :: DictBinds id,      -- Bindings involving those dictionaries
+       pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
        pat_args  :: HsConPatDetails id,
        pat_ty    :: Type               -- The type of the pattern
     }
@@ -148,7 +146,7 @@ data Pat id
                    Type
 
        ------------ Pattern coercions (translation only) ---------------
-  | CoPat      HsWrapper               -- If co::t1 -> t2, p::t2, 
+  | CoPat      HsWrapper               -- If co :: t1 ~ t2, p :: t2, 
                                        -- then (CoPat co p) :: t1
                (Pat id)                -- Why not LPat?  Ans: existing locn will do
                Type                    -- Type of whole pattern, t1
@@ -276,7 +274,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
     if debugStyle sty then     -- typechecked Pat in an error message, 
                                -- and we want to make sure it prints nicely
        ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts),
-                         pprLHsBinds binds, pprConArgs details]
+                         ppr binds, pprConArgs details]
     else pprUserCon con details
 
 pprPat (LitPat s)          = ppr s
@@ -331,7 +329,7 @@ mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
 -- Make a vanilla Prefix constructor pattern
 mkPrefixConPat dc pats ty 
   = noLoc $ ConPatOut { pat_con = noLoc dc, pat_tvs = [], pat_dicts = [],
-                       pat_binds = emptyLHsBinds, pat_args = PrefixCon pats, 
+                       pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, 
                        pat_ty = ty }
 
 mkNilPat :: Type -> OutPat id
@@ -339,15 +337,6 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] ty
 
 mkCharLitPat :: Char -> OutPat id
 mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
-
-mkCoPat :: HsWrapper -> Pat id -> Type -> Pat id
-mkCoPat co pat ty
-  | isIdHsWrapper co = pat
-  | otherwise        = CoPat co pat ty
-
-mkCoPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkCoPatCoI IdCo     pat _  = pat
-mkCoPatCoI (ACo co) pat ty = mkCoPat (WpCast co) pat ty
 \end{code}
 
 
@@ -381,41 +370,15 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-isWildPat :: Pat id -> Bool
-isWildPat (WildPat _) = True
-isWildPat _           = False
-
-patsAreAllCons :: [Pat id] -> Bool
-patsAreAllCons pat_list = all isConPat pat_list
-
-isConPat :: Pat id -> Bool
-isConPat (AsPat _ pat)  = isConPat (unLoc pat)
-isConPat (ConPatIn {})  = True
-isConPat (ConPatOut {})  = True
-isConPat (ListPat {})   = True
-isConPat (PArrPat {})   = True
-isConPat (TuplePat {})  = True
-isConPat _               = False
-
-isSigPat :: Pat id -> Bool
-isSigPat (SigPatIn _ _)  = True
-isSigPat (SigPatOut _ _) = True
-isSigPat _               = False
-
-patsAreAllLits :: [Pat id] -> Bool
-patsAreAllLits pat_list = all isLitPat pat_list
-
-isLitPat :: Pat id -> Bool
-isLitPat (AsPat _ pat)         = isLitPat (unLoc pat)
-isLitPat (LitPat _)            = True
-isLitPat (NPat _ _ _)          = True
-isLitPat (NPlusKPat _ _ _ _)    = True
-isLitPat _                      = False
+isBangLPat :: LPat id -> Bool
+isBangLPat (L _ (BangPat {})) = True
+isBangLPat (L _ (ParPat p))   = isBangLPat p
+isBangLPat _                  = False
 
 isBangHsBind :: HsBind id -> Bool
 -- In this module because HsPat is above HsBinds in the import graph
-isBangHsBind (PatBind { pat_lhs = L _ (BangPat _) }) = True
-isBangHsBind _                                       = False
+isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
+isBangHsBind _                         = False
 
 isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
index a5e8982..38608a4 100644 (file)
@@ -359,8 +359,8 @@ pprHsForAll exp tvs cxt
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []                = empty
 pprHsContext [L _ pred] 
-   | noParenHsPred pred = ppr pred <+> ptext (sLit "=>")
-pprHsContext cxt        = ppr_hs_context cxt <+> ptext (sLit "=>")
+   | noParenHsPred pred = ppr pred <+> darrow
+pprHsContext cxt        = ppr_hs_context cxt <+> darrow
 
 noParenHsPred :: HsPred name -> Bool
 -- c.f. TypeRep.noParenPred
index cfd2799..f01fb6e 100644 (file)
@@ -19,8 +19,9 @@ module HsUtils(
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   mkMatchGroup, mkMatch, mkHsLam,
-  mkHsWrap, mkLHsWrap, mkHsWrapCoI, coiToHsWrapper, mkHsDictLet,
-  mkHsOpApp, mkHsDo,
+  mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
+  coiToHsWrapper, mkHsDictLet,
+  mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
@@ -52,7 +53,7 @@ module HsUtils(
   noRebindableInfo, 
 
   -- Collecting binders
-  collectLocalBinders, collectHsValBinders, 
+  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
@@ -132,13 +133,25 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e
                 | otherwise           = HsWrap co_fn e
 
 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
-mkHsWrapCoI IdCo     e = e
+mkHsWrapCoI (IdCo _) e = e
 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
 
+mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
+mkLHsWrapCoI (IdCo _) e         = e
+mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+
 coiToHsWrapper :: CoercionI -> HsWrapper
-coiToHsWrapper IdCo     = idHsWrapper
+coiToHsWrapper (IdCo _) = idHsWrapper
 coiToHsWrapper (ACo co) = WpCast co
 
+mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
+                      | otherwise           = CoPat co_fn p ty
+
+mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
+mkHsWrapPatCoI (IdCo _) pat _  = pat
+mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
        where
@@ -147,14 +160,8 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 
-mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
--- Used for the dictionary bindings gotten from TcSimplify
--- We make them recursive to be on the safe side
-mkHsDictLet binds expr 
-  | isEmptyLHsBinds binds = expr
-  | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
-                         where
-                           val_binds = ValBindsOut [(Recursive, binds)] []
+mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
+mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictionary terms etc, so no locations 
@@ -219,7 +226,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
                       , recS_bind_fn = noSyntaxExpr
-                       , recS_rec_rets = [], recS_dicts = emptyLHsBinds }
+                       , recS_rec_rets = [], recS_dicts = emptyTcEvBinds }
 
 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 
@@ -461,6 +468,9 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 collectHsBindsBinders binds = collect_binds binds []
 
+collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
+collectHsBindListBinders = foldr (collect_bind . unLoc) []
+
 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 
@@ -507,7 +517,8 @@ collect_lpat (L _ pat) bndrs
   = go pat
   where
     go (VarPat var)              = var : bndrs
-    go (VarPatOut var bs)        = var : collect_binds bs bndrs
+    go (VarPatOut var _)         = var : bndrs
+       -- See Note [Dictionary binders in ConPatOut]
     go (WildPat _)               = bndrs
     go (LazyPat pat)             = collect_lpat pat bndrs
     go (BangPat pat)             = collect_lpat pat bndrs
index 8a3dfd7..de57feb 100644 (file)
@@ -5,10 +5,12 @@
 
 \begin{code}
 module BuildTyCl (
-       buildSynTyCon, buildAlgTyCon, buildDataCon,
+       buildSynTyCon, 
+        buildAlgTyCon, 
+        buildDataCon,
        TcMethInfo, buildClass,
-       mkAbstractTyConRhs, mkOpenDataTyConRhs, 
-       mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation
+       mkAbstractTyConRhs, 
+       mkNewTyConRhs, mkDataTyConRhs
     ) where
 
 #include "HsVersions.h"
@@ -27,7 +29,7 @@ import Type
 import Coercion
 
 import TcRnMonad
-import Util            ( count )
+import Data.List       ( partition )
 import Outputable
 \end{code}
        
@@ -35,29 +37,22 @@ import Outputable
 \begin{code}
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
-              -> SynTyConRhs 
+              -> SynTyConRhs
              -> Kind                   -- ^ Kind of the RHS
-             -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
+             -> TyConParent
+             -> Maybe (TyCon, [Type])    -- ^ family instance if applicable
               -> TcRnIf m n TyCon
-
-buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
-  = let
-      kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
-    in
-    return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
-    
-buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
-  = do { -- We need to tie a knot as the coercion of a data instance depends
-        -- on the instance representation tycon and vice versa.
-       ; tycon <- fixM (\ tycon_rec -> do 
-        { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
-        ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
-              ; kind    = mkArrowKinds (map tyVarKind tvs) rhs_kind
-              }
-         ; return tycon
-         })
-       ; return tycon 
-       }
+buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family 
+  | Just fam_inst_info <- mb_family
+  = ASSERT( isNoParent parent )
+    fixM $ \ tycon_rec -> do 
+    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec 
+    ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) }
+
+  | otherwise
+  = return (mkSynTyCon tc_name kind tvs rhs parent)
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
 
 ------------------------------------------------------
 buildAlgTyCon :: Name -> [TyVar] 
@@ -66,23 +61,26 @@ buildAlgTyCon :: Name -> [TyVar]
              -> RecFlag
              -> Bool                   -- ^ True <=> want generics functions
              -> Bool                   -- ^ True <=> was declared in GADT syntax
+              -> TyConParent
              -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
              -> TcRnIf m n TyCon
 
 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
-             mb_family
-  = do { -- We need to tie a knot as the coercion of a data instance depends
-        -- on the instance representation tycon and vice versa.
-       ; tycon <- fixM (\ tycon_rec -> do 
-        { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
-        ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
-                                   parent is_rec want_generics gadt_syn
-              ; kind  = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
-              }
-         ; return tycon
-         })
-       ; return tycon 
-       }
+             parent mb_family
+  | Just fam_inst_info <- mb_family
+  = -- We need to tie a knot as the coercion of a data instance depends
+     -- on the instance representation tycon and vice versa.
+    ASSERT( isNoParent parent )
+    fixM $ \ tycon_rec -> do 
+    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
+    ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+                        fam_parent is_rec want_generics gadt_syn) }
+
+  | otherwise
+  = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+                      parent is_rec want_generics gadt_syn)
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 
 -- | If a family tycon with instance types is given, the current tycon is an
 -- instance of that family and we need to
@@ -95,27 +93,21 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 -- (2) produce a `TyConParent' value containing the parent and coercion
 --     information.
 --
-mkParentInfo :: Maybe (TyCon, [Type]) 
-             -> Name -> [TyVar] 
-             -> TyCon 
-             -> TcRnIf m n TyConParent
-mkParentInfo Nothing                  _       _   _         =
-  return NoParentTyCon
-mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
-  do { -- Create the coercion
-     ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
-     ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
+mkFamInstParentInfo :: Name -> [TyVar] 
+                   -> (TyCon, [Type]) 
+                   -> TyCon 
+                   -> TcRnIf m n TyConParent
+mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
+  = do { -- Create the coercion
+       ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
+       ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
                                         family instTys rep_tycon
-     ; return $ FamilyTyCon family instTys co_tycon
-     }
+       ; return $ FamInstTyCon family instTys co_tycon }
     
 ------------------------------------------------------
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
-mkOpenDataTyConRhs :: AlgTyConRhs
-mkOpenDataTyConRhs = OpenTyCon Nothing
-
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
   = DataTyCon {
@@ -182,13 +174,6 @@ mkNewTyConRhs tycon_name tycon con
     eta_reduce tvs ty = (reverse tvs, ty)
                                
 
-setAssocFamilyPermutation :: [TyVar] -> TyThing -> TyThing
-setAssocFamilyPermutation clas_tvs (ATyCon tc) 
-  = ATyCon (setTyConArgPoss clas_tvs tc)
-setAssocFamilyPermutation _clas_tvs other
-  = pprPanic "setAssocFamilyPermutation" (ppr other)
-
-
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
            -> [HsBang] 
@@ -249,9 +234,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate 
                                             -- between tcClassSigs and buildClass
 
-buildClass :: Bool                     -- True <=> do not include unfoldings 
-                                       --          on dict selectors
-                                       -- Used when importing a class without -O
+buildClass :: Bool             -- True <=> do not include unfoldings 
+                               --          on dict selectors
+                               -- Used when importing a class without -O
           -> Name -> [TyVar] -> ThetaType
           -> [FunDep TyVar]               -- Functional dependencies
           -> [TyThing]                    -- Associated types
@@ -272,14 +257,14 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
                        -- Build the selector id and default method id
 
-       ; let n_value_preds   = count (not . isEqPred) sc_theta
-             all_value_preds = n_value_preds == length sc_theta
+       ; let (eq_theta, dict_theta) = partition isEqPred sc_theta
+
              -- We only make selectors for the *value* superclasses, 
              -- not equality predicates 
-
        ; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
-                               [1..n_value_preds]
-        ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
+                               [1..length dict_theta]
+        ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas 
+                           | sc_name <- sc_sel_names]
              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
              -- can construct names for the selectors. Thus
              --      class (C a, C b) => D a b where ...
@@ -287,23 +272,23 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
              --      D_sc1, D_sc2
              -- (We used to call them D_C, but now we can have two different
              --  superclasses both called C!)
-             --
        
-       ; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
+       ; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1)
                -- Use a newtype if the data constructor has 
                --      (a) exactly one value field
                --      (b) no existential or equality-predicate fields
                -- i.e. exactly one operation or superclass taken together
                -- See note [Class newtypes and equality predicates]
 
-               -- We play a bit fast and loose by treating the superclasses
-               -- as ordinary arguments.  That means that in the case of
+               -- We play a bit fast and loose by treating the dictionary
+               -- superclasses as ordinary arguments.  That means that in 
+                -- the case of
                --     class C a => D a
                -- we don't get a newtype with no arguments!
              args      = sc_sel_names ++ op_names
-             arg_tys   = map mkPredTy sc_theta ++ op_tys
              op_tys    = [ty | (_,_,ty) <- sig_stuff]
              op_names  = [op | (op,_,_) <- sig_stuff]
+             arg_tys   = map mkPredTy dict_theta ++ op_tys
               rec_tycon = classTyCon rec_clas
                
        ; dict_con <- buildDataCon datacon_name
@@ -311,7 +296,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
                                   (map (const HsNoBang) args)
                                   [{- No fields -}]
                                   tvs [{- no existentials -}]
-                                   [{- No GADT equalities -}] [{- No theta -}]
+                                   [{- No GADT equalities -}] 
+                                   eq_theta
                                    arg_tys
                                   (mkTyConApp rec_tycon (mkTyVarTys tvs))
                                   rec_tycon
@@ -335,7 +321,9 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
              ; atTyCons = [tycon | ATyCon tycon <- ats]
 
              ; result = mkClass class_name tvs fds 
-                                sc_theta sc_sel_ids atTyCons
+                                (eq_theta ++ dict_theta)  -- Equalities first
+                                 (length eq_theta)        -- Number of equalities
+                                 sc_sel_ids atTyCons
                                 op_items tycon
              }
        ; traceIf (text "buildClass" <+> ppr tycon) 
index 442ecf2..47772d7 100644 (file)
@@ -265,7 +265,7 @@ instance Outputable IfaceTyCon where
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
 pprIfaceContext []     = empty
-pprIfaceContext theta = ppr_preds theta <+> ptext (sLit "=>")
+pprIfaceContext theta = ppr_preds theta <+> darrow
 
 ppr_preds :: [IfacePredType] -> SDoc
 ppr_preds [pred] = ppr pred    -- No parens
index ce08f6d..31e5875 100644 (file)
@@ -31,7 +31,6 @@ import TcRnMonad
 
 import PrelNames
 import PrelInfo
-import PrelRules
 import Rules
 import Annotations
 import InstEnv
index 5c236b3..fa9e0ec 100644 (file)
@@ -62,6 +62,7 @@ import Class
 import TyCon
 import DataCon
 import Type
+import Coercion
 import TcType
 import InstEnv
 import FamInstEnv
@@ -318,7 +319,10 @@ mkIface_ hsc_env maybe_old_fingerprint
      le_occ n1 n2 = nameOccName n1 <= nameOccName n2
 
      dflags = hsc_dflags hsc_env
+
+     deliberatelyOmitted :: String -> a
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
 
      flattenVectInfo (VectInfo { vectInfoVar   = vVar
@@ -1377,14 +1381,14 @@ tyThingToIfaceDecl (ATyCon tycon)
     tyvars = tyConTyVars tycon
     (syn_rhs, syn_ki) 
        = case synTyConRhs tycon of
-           OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
-           SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
+           SynFamilyTyCon  -> (Nothing,               toIfaceType (synTyConResKind tycon))
+           SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
 
     ifaceConDecls (NewTyCon { data_con = con })     = 
       IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons })  = 
       IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
+    ifaceConDecls DataFamilyTyCon {}                = IfOpenDataTyCon
     ifaceConDecls AbstractTyCon                            = IfAbstractTyCon
        -- The last case happens when a TyCon has been trimmed during tidying
        -- Furthermore, tyThingToIfaceDecl is also used
index 1f846d3..83a2458 100644 (file)
@@ -414,16 +414,21 @@ the forkM stuff.
 tcIfaceDecl :: Bool    -- True <=> discard IdInfo on IfaceId bindings
            -> IfaceDecl
            -> IfL TyThing
-
-tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, 
-                                  ifIdDetails = details, ifIdInfo = info})
+tcIfaceDecl = tc_iface_decl NoParentTyCon
+
+tc_iface_decl :: TyConParent   -- For nested declarations
+              -> Bool  -- True <=> discard IdInfo on IfaceId bindings
+             -> IfaceDecl
+             -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, 
+                                      ifIdDetails = details, ifIdInfo = info})
   = do { name <- lookupIfaceTop occ_name
        ; ty <- tcIfaceType iface_type
        ; details <- tcIdDetails ty details
        ; info <- tcIdInfo ignore_prags name ty info
        ; return (AnId (mkGlobalId details name ty info)) }
 
-tcIfaceDecl _ (IfaceData {ifName = occ_name, 
+tc_iface_decl parent _ (IfaceData {ifName = occ_name, 
                          ifTyVars = tv_bndrs, 
                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                          ifCons = rdr_cons, 
@@ -434,34 +439,33 @@ tcIfaceDecl _ (IfaceData {ifName = occ_name,
     { tc_name <- lookupIfaceTop occ_name
     ; tycon <- fixM ( \ tycon -> do
            { stupid_theta <- tcIfaceCtxt ctxt
-           ; mb_fam_inst  <- tcFamInst mb_family
            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
-           ; buildAlgTyCon tc_name tyvars stupid_theta
-                           cons is_rec want_generic gadt_syn mb_fam_inst
+           ; mb_fam_inst  <- tcFamInst mb_family
+           ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
+                           want_generic gadt_syn parent mb_fam_inst
            })
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
 
-tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-                        ifSynRhs = mb_rhs_ty,
-                        ifSynKind = kind, ifFamInst = mb_family})
+tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
+                                 ifSynRhs = mb_rhs_ty,
+                                 ifSynKind = kind, ifFamInst = mb_family})
    = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
-     { tc_name <- lookupIfaceTop occ_name
+     { tc_name  <- lookupIfaceTop occ_name
      ; rhs_kind <- tcIfaceType kind    -- Note [Synonym kind loop]
-     ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ 
-                             do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
-                        ; fam <- tcFamInst mb_family
-                        ; return (rhs, fam) }
-     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
-     ; return $ ATyCon tycon
+     ; rhs      <- forkM (mk_doc tc_name) $ 
+                          tc_syn_rhs mb_rhs_ty
+     ; fam_info <- tcFamInst mb_family
+     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
+     ; return (ATyCon tycon)
      }
    where
      mk_doc n = ptext (sLit "Type syonym") <+> ppr n
-     tc_syn_rhs kind Nothing   = return (OpenSynTyCon kind Nothing)
-     tc_syn_rhs _    (Just ty) = do { rhs_ty <- tcIfaceType ty
-                                   ; return (SynonymTyCon rhs_ty) }
+     tc_syn_rhs Nothing   = return SynFamilyTyCon
+     tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
+                              ; return (SynonymTyCon rhs_ty) }
 
-tcIfaceDecl ignore_prags
+tc_iface_decl _parent ignore_prags
            (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
                         ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
                         ifATs = rdr_ats, ifSigs = rdr_sigs, 
@@ -473,9 +477,9 @@ tcIfaceDecl ignore_prags
     ; ctxt <- tcIfaceCtxt rdr_ctxt
     ; sigs <- mapM tc_sig rdr_sigs
     ; fds  <- mapM tc_fd rdr_fds
-    ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
-    ; let ats = map (setAssocFamilyPermutation tyvars) ats'
-    ; cls  <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
+    ; cls  <- fixM $ \ cls -> do
+              { ats  <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
+              ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
     ; return (AClass cls) }
   where
    tc_sig (IfaceClassOp occ dm rdr_ty)
@@ -492,7 +496,7 @@ tcIfaceDecl ignore_prags
                           ; tvs2' <- mapM tcIfaceTyVar tvs2
                           ; return (tvs1', tvs2') }
 
-tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
   = do { name <- lookupIfaceTop rdr_name
        ; return (ATyCon (mkForeignTyCon name ext_name 
                                         liftedTypeKind 0)) }
@@ -507,7 +511,7 @@ tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
 tcIfaceDataCons tycon_name tycon _ if_cons
   = case if_cons of
        IfAbstractTyCon  -> return mkAbstractTyConRhs
-       IfOpenDataTyCon  -> return mkOpenDataTyConRhs
+       IfOpenDataTyCon  -> return DataFamilyTyCon
        IfDataTyCon cons -> do  { data_cons <- mapM tc_con_decl cons
                                ; return (mkDataTyConRhs data_cons) }
        IfNewTyCon con   -> do  { data_con <- tc_con_decl con
index 75f31ca..557dfb4 100644 (file)
@@ -293,6 +293,7 @@ data ExtensionFlag
    | Opt_MonomorphismRestriction
    | Opt_MonoPatBinds
    | Opt_MonoLocalBinds
+   | Opt_RelaxedPolyRec                -- Deprecated
    | Opt_ExtendedDefaultRules           -- Use GHC's extended rules for defaulting
    | Opt_ForeignFunctionInterface
    | Opt_UnliftedFFITypes
@@ -314,8 +315,6 @@ data ExtensionFlag
    | Opt_RecordPuns
    | Opt_ViewPatterns
    | Opt_GADTs
-   | Opt_OutsideIn
-   | Opt_RelaxedPolyRec                -- Deprecated
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse
 
@@ -731,26 +730,9 @@ defaultDynFlags =
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
         haddockOptions = Nothing,
-        flags = [
-            Opt_AutoLinkPackages,
-            Opt_ReadUserPackageConf,
-
-            Opt_MethodSharing,
-
-            Opt_DoAsmMangling,
-
-            Opt_SharedImplib,
-
-            Opt_GenManifest,
-            Opt_EmbedManifest,
-            Opt_PrintBindContents
-            ]
-            ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
-                    -- The default -O0 options
-            ++ standardWarnings,
-
+        flags = defaultFlags,
         language = Nothing,
-        extensionFlags = Left [],
+        extensionFlags = Left defaultExtensionFlags,
 
         log_action = \severity srcSpan style msg ->
                         case severity of
@@ -1004,95 +986,6 @@ updOptLevel n dfs
    extra_dopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]
    remove_dopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]
 
-optLevelFlags :: [([Int], DynFlag)]
-optLevelFlags
-  = [ ([0],     Opt_IgnoreInterfacePragmas)
-    , ([0],     Opt_OmitInterfacePragmas)
-
-    , ([1,2],   Opt_IgnoreAsserts)
-    , ([1,2],   Opt_EnableRewriteRules)  -- Off for -O0; see Note [Scoping for Builtin rules]
-                                         --              in PrelRules
-    , ([1,2],   Opt_DoEtaReduction)
-    , ([1,2],   Opt_CaseMerge)
-    , ([1,2],   Opt_Strictness)
-    , ([1,2],   Opt_CSE)
-    , ([1,2],   Opt_FullLaziness)
-    , ([1,2],   Opt_Specialise)
-    , ([1,2],   Opt_FloatIn)
-
-    , ([2],     Opt_LiberateCase)
-    , ([2],     Opt_SpecConstr)
-    , ([2],     Opt_RegsGraph)
-
---     , ([2],     Opt_StaticArgumentTransformation)
--- Max writes: I think it's probably best not to enable SAT with -O2 for the
--- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate
--- several improvements to the heuristics, and I'm concerned that without
--- those changes SAT will interfere with some attempts to write "high
--- performance Haskell", as we saw in some posts on Haskell-Cafe earlier
--- this year. In particular, the version in HEAD lacks the tail call
--- criterion, so many things that look like reasonable loops will be
--- turned into functions with extra (unneccesary) thunk creation.
-
-    , ([0,1,2], Opt_DoLambdaEtaExpansion)
-                -- This one is important for a tiresome reason:
-                -- we want to make sure that the bindings for data
-                -- constructors are eta-expanded.  This is probably
-                -- a good thing anyway, but it seems fragile.
-    ]
-
--- -----------------------------------------------------------------------------
--- Standard sets of warning options
-
-standardWarnings :: [DynFlag]
-standardWarnings
-    = [ Opt_WarnWarningsDeprecations,
-        Opt_WarnDeprecatedFlags,
-        Opt_WarnUnrecognisedPragmas,
-        Opt_WarnOverlappingPatterns,
-        Opt_WarnMissingFields,
-        Opt_WarnMissingMethods,
-        Opt_WarnDuplicateExports,
-        Opt_WarnLazyUnliftedBindings,
-        Opt_WarnDodgyForeignImports,
-        Opt_WarnWrongDoBind,
-        Opt_WarnAlternativeLayoutRuleTransitional
-      ]
-
-minusWOpts :: [DynFlag]
-minusWOpts
-    = standardWarnings ++
-      [ Opt_WarnUnusedBinds,
-        Opt_WarnUnusedMatches,
-        Opt_WarnUnusedImports,
-        Opt_WarnIncompletePatterns,
-        Opt_WarnDodgyExports,
-        Opt_WarnDodgyImports
-      ]
-
-minusWallOpts :: [DynFlag]
-minusWallOpts
-    = minusWOpts ++
-      [ Opt_WarnTypeDefaults,
-        Opt_WarnNameShadowing,
-        Opt_WarnMissingSigs,
-        Opt_WarnHiShadows,
-        Opt_WarnOrphans,
-        Opt_WarnUnusedDoBind
-      ]
-
--- minuswRemovesOpts should be every warning option
-minuswRemovesOpts :: [DynFlag]
-minuswRemovesOpts
-    = minusWallOpts ++
-      [Opt_WarnImplicitPrelude,
-       Opt_WarnIncompletePatternsRecUpd,
-       Opt_WarnSimplePatterns,
-       Opt_WarnMonomorphism,
-       Opt_WarnUnrecognisedPragmas,
-       Opt_WarnTabs
-      ]
-
 -- -----------------------------------------------------------------------------
 -- StgToDo:  abstraction of stg-to-stg passes to run.
 
@@ -1558,8 +1451,7 @@ fFlags = [
   ( "warn-orphans",                     Opt_WarnOrphans, nop ),
   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
-  ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings,
-    \_ -> deprecate "lazy unlifted bindings will be an error in GHC 6.14, and this flag will no longer exist"),
+  ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),
   ( "warn-unused-do-bind",              Opt_WarnUnusedDoBind, nop ),
   ( "warn-wrong-do-bind",               Opt_WarnWrongDoBind, nop ),
   ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ),
@@ -1746,6 +1638,31 @@ xFlags = [
     \_ -> deprecate "The new qualified operator syntax was rejected by Haskell'" )
   ]
 
+defaultFlags :: [DynFlag]
+defaultFlags 
+  = [ Opt_AutoLinkPackages,
+      Opt_ReadUserPackageConf,
+
+      Opt_MethodSharing,
+
+      Opt_DoAsmMangling,
+
+      Opt_SharedImplib,
+
+      Opt_GenManifest,
+      Opt_EmbedManifest,
+      Opt_PrintBindContents
+    ]
+
+    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
+             -- The default -O0 options
+
+    ++ standardWarnings
+
+defaultExtensionFlags :: [OnOff ExtensionFlag]
+defaultExtensionFlags 
+  = []         -- In due course I'd like Opt_MonoLocalBinds to be on by default
+
 impliedFlags :: [(ExtensionFlag, ExtensionFlag)]
 impliedFlags
   = [ (Opt_RankNTypes,                Opt_ExplicitForAll)
@@ -1755,15 +1672,13 @@ impliedFlags
     , (Opt_ExistentialQuantification, Opt_ExplicitForAll)
     , (Opt_PolymorphicComponents,     Opt_ExplicitForAll)
 
-    , (Opt_GADTs,               Opt_OutsideIn)       -- We want type-sig variables to
-                                                     --      be completely rigid for GADTs
+    , (Opt_GADTs,                  Opt_MonoLocalBinds)
+    , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
+    , (Opt_FunctionalDependencies, Opt_MonoLocalBinds)
 
-    , (Opt_TypeFamilies,        Opt_OutsideIn)       -- Trac #2944 gives a nice example
     , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
                                                     -- all over the place
 
-    , (Opt_ScopedTypeVariables, Opt_OutsideIn)       -- Ditto for scoped type variables; see
-                                                     --      Note [Scoped tyvars] in TcBinds
     , (Opt_ImpredicativeTypes,  Opt_RankNTypes)
 
        -- Record wild-cards implies field disambiguation
@@ -1773,6 +1688,95 @@ impliedFlags
     , (Opt_RecordWildCards,     Opt_DisambiguateRecordFields)
   ]
 
+optLevelFlags :: [([Int], DynFlag)]
+optLevelFlags
+  = [ ([0],     Opt_IgnoreInterfacePragmas)
+    , ([0],     Opt_OmitInterfacePragmas)
+
+    , ([1,2],   Opt_IgnoreAsserts)
+    , ([1,2],   Opt_EnableRewriteRules)  -- Off for -O0; see Note [Scoping for Builtin rules]
+                                         --              in PrelRules
+    , ([1,2],   Opt_DoEtaReduction)
+    , ([1,2],   Opt_CaseMerge)
+    , ([1,2],   Opt_Strictness)
+    , ([1,2],   Opt_CSE)
+    , ([1,2],   Opt_FullLaziness)
+    , ([1,2],   Opt_Specialise)
+    , ([1,2],   Opt_FloatIn)
+
+    , ([2],     Opt_LiberateCase)
+    , ([2],     Opt_SpecConstr)
+    , ([2],     Opt_RegsGraph)
+
+--     , ([2],     Opt_StaticArgumentTransformation)
+-- Max writes: I think it's probably best not to enable SAT with -O2 for the
+-- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate
+-- several improvements to the heuristics, and I'm concerned that without
+-- those changes SAT will interfere with some attempts to write "high
+-- performance Haskell", as we saw in some posts on Haskell-Cafe earlier
+-- this year. In particular, the version in HEAD lacks the tail call
+-- criterion, so many things that look like reasonable loops will be
+-- turned into functions with extra (unneccesary) thunk creation.
+
+    , ([0,1,2], Opt_DoLambdaEtaExpansion)
+                -- This one is important for a tiresome reason:
+                -- we want to make sure that the bindings for data
+                -- constructors are eta-expanded.  This is probably
+                -- a good thing anyway, but it seems fragile.
+    ]
+
+-- -----------------------------------------------------------------------------
+-- Standard sets of warning options
+
+standardWarnings :: [DynFlag]
+standardWarnings
+    = [ Opt_WarnWarningsDeprecations,
+        Opt_WarnDeprecatedFlags,
+        Opt_WarnUnrecognisedPragmas,
+        Opt_WarnOverlappingPatterns,
+        Opt_WarnMissingFields,
+        Opt_WarnMissingMethods,
+        Opt_WarnDuplicateExports,
+        Opt_WarnLazyUnliftedBindings,
+        Opt_WarnDodgyForeignImports,
+        Opt_WarnWrongDoBind,
+        Opt_WarnAlternativeLayoutRuleTransitional
+      ]
+
+minusWOpts :: [DynFlag]
+minusWOpts
+    = standardWarnings ++
+      [ Opt_WarnUnusedBinds,
+        Opt_WarnUnusedMatches,
+        Opt_WarnUnusedImports,
+        Opt_WarnIncompletePatterns,
+        Opt_WarnDodgyExports,
+        Opt_WarnDodgyImports
+      ]
+
+minusWallOpts :: [DynFlag]
+minusWallOpts
+    = minusWOpts ++
+      [ Opt_WarnTypeDefaults,
+        Opt_WarnNameShadowing,
+        Opt_WarnMissingSigs,
+        Opt_WarnHiShadows,
+        Opt_WarnOrphans,
+        Opt_WarnUnusedDoBind
+      ]
+
+-- minuswRemovesOpts should be every warning option
+minuswRemovesOpts :: [DynFlag]
+minuswRemovesOpts
+    = minusWallOpts ++
+      [Opt_WarnImplicitPrelude,
+       Opt_WarnIncompletePatternsRecUpd,
+       Opt_WarnSimplePatterns,
+       Opt_WarnMonomorphism,
+       Opt_WarnUnrecognisedPragmas,
+       Opt_WarnTabs
+      ]
+
 enableGlasgowExts :: DynP ()
 enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls
                        mapM_ setExtensionFlag glasgowExtsFlags
index 5dfa76c..92345c7 100644 (file)
@@ -148,7 +148,7 @@ module GHC (
        TyCon, 
        tyConTyVars, tyConDataCons, tyConArity,
        isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
-       isOpenTyCon,
+       isFamilyTyCon,
        synTyConDefn, synTyConType, synTyConResKind,
 
        -- ** Type variables
@@ -247,7 +247,7 @@ import InteractiveEval
 
 import TcRnDriver
 import TcIface
-import TcRnTypes        hiding (LIE)
+import TcRnTypes
 import TcRnMonad        ( initIfaceCheck )
 import Packages
 import NameSet
@@ -255,6 +255,7 @@ import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
 import HsSyn hiding ((<.>))
 import Type
+import Coercion                ( synTyConResKind )
 import TcType          hiding( typeKind )
 import Id
 import Var
index 156a04e..5c41f68 100644 (file)
@@ -129,7 +129,7 @@ import Id
 import Type            
 
 import Annotations
-import Class           ( Class, classSelIds, classATs, classTyCon )
+import Class           ( Class, classAllSelIds, classATs, classTyCon )
 import TyCon
 import DataCon         ( DataCon, dataConImplicitIds, dataConWrapId )
 import PrelNames       ( gHC_PRIM )
@@ -1333,7 +1333,7 @@ implicitTyThings (AClass cl)
     --    are only the family decls; they have no implicit things
     map ATyCon (classATs cl) ++
     -- superclass and operation selectors
-    map AnId (classSelIds cl)
+    map AnId (classAllSelIds cl)
 
 implicitTyThings (ADataCon dc) = 
     -- For data cons add the worker and (possibly) wrapper
index b10a31d..d859784 100644 (file)
@@ -112,7 +112,7 @@ pprTyConHdr _ tyCon
             | otherwise            = sLit "data"
 
     opt_family
-      | GHC.isOpenTyCon tyCon = ptext (sLit "family")
+      | GHC.isFamilyTyCon tyCon = ptext (sLit "family")
       | otherwise             = empty
 
     opt_stupid         -- The "stupid theta" part of the declaration
@@ -149,15 +149,15 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
 --     (C a, Ord b) => stuff
 pprTypeForUser print_foralls ty 
   | print_foralls = ppr tidy_ty
-  | otherwise     = ppr (mkPhiTy [p | (_tvs, ps) <- ctxt, p <- ps] ty')
+  | otherwise     = ppr (mkPhiTy ctxt ty')
   where
     tidy_ty     = tidyTopType ty
-    (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty
+    (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
 
 pprTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
 pprTyCon pefas show_me tyCon
   | GHC.isSynTyCon tyCon
-  = if GHC.isOpenTyCon tyCon
+  = if GHC.isFamilyTyCon tyCon
     then pprTyConHdr pefas tyCon <+> dcolon <+> 
         pprTypeForUser pefas (GHC.synTyConResKind tyCon)
     else 
index 143d81e..6536a13 100644 (file)
@@ -127,6 +127,7 @@ static_flags = [
   , Flag "dsuppress-module-prefixes" (PassFlag addOpt)
   , Flag "dppr-user-length"          (AnySuffix addOpt)
   , Flag "dopt-fuel"                 (AnySuffix addOpt)
+  , Flag "dtrace-level"              (AnySuffix addOpt)
   , Flag "dno-debug-output"          (PassFlag addOpt)
   , Flag "dstub-dead-values"         (PassFlag addOpt)
       -- rest of the debugging flags are dynamic
index 752c516..a8e3551 100644 (file)
@@ -24,7 +24,7 @@ module StaticFlags (
        opt_SuppressUniques,
         opt_SuppressCoercions,
        opt_SuppressModulePrefixes,
-       opt_PprStyle_Debug,
+       opt_PprStyle_Debug, opt_TraceLevel,
         opt_NoDebugOutput,
 
        -- profiling opts
@@ -193,7 +193,11 @@ opt_SuppressModulePrefixes :: Bool
 opt_SuppressModulePrefixes     = lookUp  (fsLit "-dsuppress-module-prefixes")
 
 opt_PprStyle_Debug  :: Bool
-opt_PprStyle_Debug             = lookUp  (fsLit "-dppr-debug")
+opt_PprStyle_Debug              = lookUp  (fsLit "-dppr-debug")
+
+opt_TraceLevel :: Int
+opt_TraceLevel = lookup_def_int "-dtrace-level" 1      -- Standard level is 1
+                                                       -- Less verbose is 0
 
 opt_PprUserLength   :: Int
 opt_PprUserLength              = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
index 6a0a2cf..8ce4dcd 100644 (file)
@@ -20,7 +20,7 @@ import CoreMonad
 import CoreUtils
 import Rules
 import CoreArity       ( exprArity, exprBotStrictness_maybe )
-import Class           ( classSelIds )
+import Class           ( classAllSelIds )
 import VarEnv
 import VarSet
 import Var
@@ -454,7 +454,7 @@ mustExposeTyCon exports tc
   | 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.)
-  | isOpenTyCon tc             -- Open type family
+  | isFamilyTyCon tc           -- Open type family
   = True
 
   | otherwise                  -- Newtype, datatype
@@ -560,7 +560,7 @@ getImplicitBinds type_env
   = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
   where
     implicit_ids (ATyCon tc)  = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-    implicit_ids (AClass cls) = classSelIds cls
+    implicit_ids (AClass cls) = classAllSelIds cls
     implicit_ids _            = []
     
     get_defn :: Id -> CoreBind
index d7659b5..0efc6f5 100644 (file)
@@ -356,21 +356,30 @@ slurpConflicts live
 --
 --
 slurpReloadCoalesce 
-       :: Instruction instr
+       :: forall instr. Instruction instr
        => LiveCmmTop instr
        -> Bag (Reg, Reg)
 
 slurpReloadCoalesce live
        = slurpCmm emptyBag live
 
- where slurpCmm cs CmmData{}   = cs
+ where 
+        slurpCmm :: Bag (Reg, Reg)
+                 -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
+                 -> Bag (Reg, Reg)
+        slurpCmm cs CmmData{}  = cs
        slurpCmm cs (CmmProc _ _ _ sccs)
                = slurpComp cs (flattenSCCs sccs)
 
+        slurpComp :: Bag (Reg, Reg)
+                     -> [LiveBasicBlock instr]
+                     -> Bag (Reg, Reg)
        slurpComp  cs blocks
         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
           in   unionManyBags (cs : moveBags)
 
+        slurpCompM :: [LiveBasicBlock instr]
+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
        slurpCompM blocks
         = do   -- run the analysis once to record the mapping across jumps.
                mapM_   (slurpBlock False) blocks
@@ -381,6 +390,8 @@ slurpReloadCoalesce live
                --      not worth the trouble.
                mapM    (slurpBlock True) blocks
 
+        slurpBlock :: Bool -> LiveBasicBlock instr
+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
        slurpBlock propagate (BasicBlock blockId instrs)
         = do   -- grab the slot map for entry to this block
                slotMap         <- if propagate
@@ -390,8 +401,7 @@ slurpReloadCoalesce live
                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
                return $ listToBag $ catMaybes mMoves
 
-       slurpLI :: Instruction instr
-               => UniqFM Reg                           -- current slotMap
+       slurpLI :: UniqFM Reg                           -- current slotMap
                -> LiveInstr instr
                -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
                                                        --      for tracking slotMaps across jumps
index f856313..00ce130 100644 (file)
@@ -530,7 +530,9 @@ x86_patchRegsOfInstr instr env
     _other             -> panic "patchRegs: unrecognised instr"
 
   where
+    patch1 :: (Operand -> a) -> Operand -> a
     patch1 insn op      = insn $! patchOp op
+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
     patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
 
     patchOp (OpReg  reg) = OpReg $! env reg
index b0b7751..e78b1ca 100644 (file)
@@ -791,8 +791,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
 binds  ::  { Located (HsLocalBinds RdrName) }          -- May have implicit parameters
                                                -- No type declarations
        : decllist                      { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
-       | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
-       |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
+       | '{'            dbinds '}'     { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+       |     vocurly    dbinds close   { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }       -- May have implicit parameters
                                                -- No type declarations
index c8d8483..2df4012 100644 (file)
@@ -172,7 +172,7 @@ basicKnownKeyNames
        newStablePtrName,
 
     -- GHC Extensions
-    groupWithName,
+        groupWithName,
 
        -- Strings and lists
        unpackCStringName, unpackCStringAppendName,
@@ -182,6 +182,8 @@ basicKnownKeyNames
        concatName, filterName, mapName,
        zipName, foldrName, buildName, augmentName, appendName,
 
+        dollarName,        -- The ($) apply function
+
         -- Parallel array operations
        nullPName, lengthPName, replicatePName, singletonPName, mapPName,
        filterPName, zipPName, crossMapPName, indexPName,
@@ -599,14 +601,15 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
 fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
     mapName, appendName, assertName,
     breakpointName, breakpointCondName, breakpointAutoName,
-    opaqueTyConName :: Name
+    dollarName, opaqueTyConName :: Name
 fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey
 otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey
 foldrName        = varQual gHC_BASE (fsLit "foldr")      foldrIdKey
 buildName        = varQual gHC_BASE (fsLit "build")      buildIdKey
 augmentName      = varQual gHC_BASE (fsLit "augment")    augmentIdKey
-mapName       = varQual gHC_BASE (fsLit "map")        mapIdKey
+mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey
 appendName       = varQual gHC_BASE (fsLit "++")         appendIdKey
+dollarName       = varQual gHC_BASE (fsLit "$")          dollarIdKey
 assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey
 breakpointName    = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
 breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
@@ -1199,9 +1202,10 @@ breakpointAutoJumpIdKey       = mkPreludeMiscIdUnique 67
 inlineIdKey :: Unique
 inlineIdKey                  = mkPreludeMiscIdUnique 68
 
-mapIdKey, groupWithIdKey :: Unique
-mapIdKey                     = mkPreludeMiscIdUnique 69
+mapIdKey, groupWithIdKey, dollarIdKey :: Unique
+mapIdKey             = mkPreludeMiscIdUnique 69
 groupWithIdKey        = mkPreludeMiscIdUnique 70
+dollarIdKey           = mkPreludeMiscIdUnique 71
 
 -- Parallel array functions
 singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
index 4ca4462..c148753 100644 (file)
@@ -15,32 +15,35 @@ ToDo:
 
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
-module PrelRules ( primOpRules, builtinRules ) where
+module PrelRules ( 
+    primOpRules, builtinRules,
+
+    -- Error Ids defined here because may be called here
+    mkRuntimeErrorApp, mkImpossibleExpr, 
+    rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
+    nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
+    pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
+ ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
 import MkCore          ( mkWildCase )
-import Id              ( realIdUnfolding )
-import Literal         ( Literal(..), mkMachInt, mkMachWord
-                       , literalType
-                       , word2IntLit, int2WordLit
-                       , narrow8IntLit, narrow16IntLit, narrow32IntLit
-                       , narrow8WordLit, narrow16WordLit, narrow32WordLit
-                       , char2IntLit, int2CharLit
-                       , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
-                       , float2DoubleLit, double2FloatLit, litFitsInChar
-                       )
+import Id
+import IdInfo
+import Demand
+import Literal
 import PrimOp          ( PrimOp(..), tagToEnumKey )
-import TysWiredIn      ( boolTy, trueDataConId, falseDataConId )
+import TysWiredIn
+import TysPrim
 import TyCon           ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
 import DataCon         ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
 import CoreUtils       ( cheapEqExpr )
 import CoreUnfold      ( exprIsConApp_maybe )
-import Type            ( tyConAppTyCon, coreEqType )
+import TcType          ( mkSigmaTy )
+import Type
 import OccName         ( occNameFS )
-import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
-                         eqStringName, unpackCStringIdKey, inlineIdName )
+import PrelNames
 import Maybes          ( orElse )
 import Name            ( Name, nameOccName )
 import Outputable
@@ -437,13 +440,41 @@ mkDoubleVal d = Lit (convFloating (MachDouble d))
 %*                                                                     *
 %************************************************************************
 
+Note [tagToEnum#]
+~~~~~~~~~~~~~~~~~
+Nasty check to ensure that tagToEnum# is applied to a type that is an
+enumeration TyCon.  Unification may refine the type later, but this
+check won't see that, alas.  It's crude but it works.
+
+Here's are two cases that should fail
+       f :: forall a. a
+       f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
+
+       g :: Int
+       g = tagToEnum# 0        -- Int is not an enumeration
+
+We used to make this check in the type inference engine, but it's quite
+ugly to do so, because the delayed constraint solving means that we don't
+really know what's going on until the end. It's very much a corner case
+because we don't expect the user to call tagToEnum# at all; we merely
+generate calls in derived instances of Enum.  So we compromise: a
+rewrite rule rewrites a bad instance of tagToEnum# to an error call,
+and emits a warning.
+
 \begin{code}
 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+tagToEnumRule _ [Type ty, _]
+  | not (is_enum_ty ty)          -- See Note [tagToEnum#]
+  = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
+    Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
+  where
+    is_enum_ty ty = case splitTyConApp_maybe ty of
+                       Just (tc, _) -> isEnumerationTyCon tc
+                      Nothing      -> False
+
 tagToEnumRule _ [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 
     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
-
-
        []        -> Nothing    -- Abstract type
        (dc:rest) -> ASSERT( null rest )
                     Just (Var (dataConWorkId dc))
@@ -455,6 +486,7 @@ tagToEnumRule _ [Type ty, Lit (MachInt i)]
 tagToEnumRule _ _ = Nothing
 \end{code}
 
+
 For dataToTag#, we can reduce if either 
        
        (a) the argument is a constructor
@@ -523,7 +555,8 @@ builtinRules
 
 ---------------------------------------------------
 -- The rule is this:
---     unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
+--     unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  
+--      =  unpackFoldrCString# "foobaz" c n
 
 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 match_append_lit _ [Type ty1,
@@ -580,3 +613,117 @@ match_inline _ (Type _ : e : _)
 
 match_inline _ _ = Nothing
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
+%*                                                                      *
+%************************************************************************
+b
+GHC randomly injects these into the code.
+
+@patError@ is just a version of @error@ for pattern-matching
+failures.  It knows various ``codes'' which expand to longer
+strings---this saves space!
+
+@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
+well shouldn't be yanked on, but if one is, then you will get a
+friendly message from @absentErr@ (rather than a totally random
+crash).
+
+@parError@ is a special version of @error@ which the compiler does
+not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
+templates, but we don't ever expect to generate code for it.
+
+\begin{code}
+mkRuntimeErrorApp 
+        :: Id           -- Should be of type (forall a. Addr# -> a)
+                        --      where Addr# points to a UTF8 encoded string
+        -> Type         -- The type to instantiate 'a'
+        -> String       -- The string to print
+        -> CoreExpr
+
+mkRuntimeErrorApp err_id res_ty err_msg 
+  = mkApps (Var err_id) [Type res_ty, err_string]
+  where
+    err_string = Lit (mkMachString err_msg)
+
+mkImpossibleExpr :: Type -> CoreExpr
+mkImpossibleExpr res_ty
+  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
+
+errorName, recSelErrorName, runtimeErrorName :: Name
+irrefutPatErrorName, recConErrorName, patErrorName :: Name
+nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+errorName                = mkWiredInIdName gHC_ERR (fsLit "error")            errorIdKey eRROR_ID
+recSelErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
+runtimeErrorName         = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
+irrefutPatErrorName      = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
+recConErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
+patErrorName             = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
+noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
+                                           noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
+nonExhaustiveGuardsErrorName 
+  = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") 
+                    nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
+
+rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
+pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
+rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
+rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
+iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
+rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
+pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+
+-- The runtime error Ids take a UTF8-encoded string as argument
+
+mkRuntimeErrorId :: Name -> Id
+mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+
+runtimeErrorTy :: Type
+runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
+\end{code}
+
+\begin{code}
+eRROR_ID :: Id
+eRROR_ID = pc_bottoming_Id errorName errorTy
+
+errorTy  :: Type
+errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+    -- Notice the openAlphaTyVar.  It says that "error" can be applied
+    -- to unboxed as well as boxed types.  This is OK because it never
+    -- returns, so the return type is irrelevant.
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
+\subsection{Utilities}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+pc_bottoming_Id :: Name -> Type -> Id
+-- Function of arity 1, which diverges after being given one argument
+pc_bottoming_Id name ty
+ = mkVanillaGlobalWithInfo name ty bottoming_info
+ where
+    bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
+                                  `setArityInfo`         1
+                       -- Make arity and strictness agree
+
+        -- Do *not* mark them as NoCafRefs, because they can indeed have
+        -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
+        -- which has some CAFs
+        -- In due course we may arrange that these error-y things are
+        -- regarded by the GC as permanently live, in which case we
+        -- can give them NoCaf info.  As it is, any function that calls
+        -- any pc_bottoming_Id will itself have CafRefs, which bloats
+        -- SRTs.
+
+    strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+        -- These "bottom" out, no matter what their arguments
+\end{code}
+
index 9efe64e..fd5695b 100644 (file)
@@ -222,7 +222,7 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
 rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
 rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
-    return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s)
+    return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
 
 rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
 rnIPBind (IPBind n expr) = do
@@ -419,41 +419,19 @@ rnBindLHS :: NameMaker
           -- (i.e., any free variables of the pattern)
           -> RnM (LHsBindLR Name RdrName)
 
-rnBindLHS name_maker _ (L loc (PatBind { pat_lhs = pat, 
-                                         pat_rhs = grhss, 
-                                         pat_rhs_ty=pat_rhs_ty
-                                       })) 
+rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat }))
   = setSrcSpan loc $ do
       -- we don't actually use the FV processing of rnPatsAndThen here
       (pat',pat'_fvs) <- rnBindPat name_maker pat
-      return (L loc (PatBind { pat_lhs = pat', 
-                               pat_rhs = grhss, 
-                               -- we temporarily store the pat's FVs here;
-                               -- gets updated to the FVs of the whole bind
-                               -- when doing the RHS below
-                               bind_fvs = pat'_fvs,
-                               -- these will get ignored in the next pass,
-                               -- when we rename the RHS
-                              pat_rhs_ty = pat_rhs_ty }))
-
-rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _), 
-                                         fun_infix = inf, 
-                                         fun_matches = matches,
-                                         fun_co_fn = fun_co_fn, 
-                                         fun_tick = fun_tick
-                                       }))
+      return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs }))
+                -- We temporarily store the pat's FVs in bind_fvs;
+                -- gets updated to the FVs of the whole bind
+                -- when doing the RHS below
+                            
+rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) }))
   = setSrcSpan loc $ 
     do { newname <- applyNameMaker name_maker name
-       ; return (L loc (FunBind { fun_id = L nameLoc newname, 
-                                 fun_infix = inf, 
-                                 fun_matches = matches,
-                                 -- we temporatily store the LHS's FVs (empty in this case) here
-                                 -- gets updated when doing the RHS below
-                                 bind_fvs = emptyFVs,
-                                 -- everything else will get ignored in the next pass
-                                 fun_co_fn = fun_co_fn, 
-                                 fun_tick = fun_tick
-                                 })) }
+       ; return (L loc (bind { fun_id = L nameLoc newname })) } 
 
 rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
 
@@ -462,13 +440,13 @@ rnBind :: (Name -> [Name])                -- Signature tyvar function
        -> (FreeVars -> FreeVars)       -- Trimming function for rhs free vars
        -> LHsBindLR Name RdrName
        -> RnM (LHsBind Name, [Name], Uses)
-rnBind _ trim (L loc (PatBind { pat_lhs = pat,
-                                pat_rhs = grhss, 
-                                -- pat fvs were stored here while
-                                -- after processing the LHS          
-                                bind_fvs = pat_fvs }))
+rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
+                                   , pat_rhs = grhss 
+                                      -- pat fvs were stored in bind_fvs
+                                      -- after processing the LHS          
+                                   , bind_fvs = pat_fvs }))
   = setSrcSpan loc $ 
-    do {let bndrs = collectPatBinders pat
+    do { let bndrs = collectPatBinders pat
 
        ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
                -- No scoped type variables for pattern bindings
@@ -476,20 +454,14 @@ rnBind _ trim (L loc (PatBind { pat_lhs = pat,
               fvs'    = trim all_fvs
 
        ; fvs' `seq` -- See Note [Free-variable space leak]
-          return (L loc (PatBind { pat_lhs    = pat,
-                                   pat_rhs    = grhss', 
-                                  pat_rhs_ty = placeHolderType, 
-                                   bind_fvs   = fvs' }),
+          return (L loc (bind { pat_rhs  = grhss' 
+                             , bind_fvs = fvs' }),
                  bndrs, all_fvs) }
 
-rnBind sig_fn 
-       trim 
-       (L loc (FunBind { fun_id = name, 
-                         fun_infix = is_infix, 
-                         fun_matches = matches,
-                         -- no pattern FVs
-                         bind_fvs = _
-                       })) 
+rnBind sig_fn trim 
+       (L loc bind@(FunBind { fun_id = name 
+                            , fun_infix = is_infix 
+                            , fun_matches = matches })) 
        -- invariant: no free vars here when it's a FunBind
   = setSrcSpan loc $ 
     do { let plain_name = unLoc name
@@ -503,12 +475,8 @@ rnBind sig_fn
 
        ; fvs' `seq` -- See Note [Free-variable space leak]
 
-          return (L loc (FunBind { fun_id = name,
-                                          fun_infix = is_infix, 
-                                          fun_matches = matches',
-                                  bind_fvs = fvs',
-                                          fun_co_fn = idHsWrapper, 
-                                          fun_tick = Nothing }), 
+          return (L loc (bind { fun_matches = matches'
+                             , bind_fvs   = fvs' }), 
                  [plain_name], fvs)
       }
 
@@ -619,8 +587,9 @@ rnMethodBind :: Name
              -> [Name]
              -> LHsBindLR RdrName RdrName
              -> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = is_infix, 
-                                                    fun_matches = MatchGroup matches _ }))
+rnMethodBind cls sig_fn gen_tyvars 
+             (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix 
+                                 , fun_matches = MatchGroup matches _ }))
   = setSrcSpan loc $ do
     sel_name <- wrapLocM (lookupInstDeclBndr cls) name
     let plain_name = unLoc sel_name
@@ -631,11 +600,9 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix =
     let new_group = MatchGroup new_matches placeHolderType
 
     when is_infix $ checkPrecMatch plain_name new_group
-    return (unitBag (L loc (FunBind {
-                                fun_id = sel_name, fun_infix = is_infix,
-                                fun_matches = new_group,
-                                bind_fvs = fvs, fun_co_fn = idHsWrapper,
-                                fun_tick = Nothing })),
+    return (unitBag (L loc (bind { fun_id      = sel_name 
+                                 , fun_matches = new_group
+                                 , bind_fvs    = fvs })),
              fvs `addOneFV` plain_name)
         -- The 'fvs' field isn't used for method binds
   where
index 2f62681..4cba23b 100644 (file)
@@ -20,7 +20,7 @@ import RnEnv
 import RnHsDoc          ( rnHsDoc )
 import IfaceEnv                ( ifaceExportNames )
 import LoadIface       ( loadSrcInterface, loadSysInterface )
-import TcRnMonad hiding (LIE)
+import TcRnMonad
 
 import HeaderInfo       ( mkPrelImports )
 import PrelNames
@@ -600,7 +600,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
        -- different parents).  See the discussion at occ_env.
     lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)]
     lookup_ie opt_typeFamilies ie 
-      = let bad_ie = Failed (badImportItemErr iface decl_spec ie)
+      = let bad_ie :: MaybeErr Message a
+            bad_ie = Failed (badImportItemErr iface decl_spec ie)
 
             lookup_name rdr 
              | isQual rdr = Failed (qualImportItemErr rdr)
index e362a12..9e16379 100644 (file)
@@ -209,7 +209,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
 
    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
    traceRn (text "finish Dus" <+> ppr src_dus ) ;
-   return (final_tcg_env , rn_group)
+   return (final_tcg_env, rn_group)
                     }}}}
 
 -- some utils because we do this a bunch above
index cf53e91..b9f44c9 100644 (file)
@@ -198,7 +198,7 @@ fiExpr to_drop lam@(_, AnnLam _ _)
 
     go seen_one_shot_id [] = seen_one_shot_id
     go seen_one_shot_id (b:bs)
-      | isTyVar       b = go seen_one_shot_id bs
+      | isTyCoVar       b = go seen_one_shot_id bs
       | isOneShotBndr b = go True bs
       | otherwise       = False         -- Give up at a non-one-shot Id
 \end{code}
index 579565f..fba88e7 100644 (file)
@@ -242,7 +242,7 @@ floatExpr _ lam@(Lam _ _)
        -- going to escape a value lambda.
        -- In particular, for one-shot lambdas we don't float things
        -- out; we get no saving by so doing.
-       partition_fn | all isTyVar bndrs = partitionByLevel
+       partition_fn | all isTyCoVar bndrs = partitionByLevel
                     | otherwise         = partitionByMajorLevel
     in
     case (floatExpr (last lvls) body) of { (fs, floats, body') ->
index 22e042a..a37b5f1 100644 (file)
@@ -28,6 +28,7 @@ import BasicTypes
 
 import VarSet
 import VarEnv
+import Var             ( Var, varUnique )
 
 import Maybes           ( orElse )
 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVerticesR )
@@ -91,7 +92,7 @@ occAnalBind :: OccEnv                 -- The incoming OccEnv
                 [CoreBind])
 
 occAnalBind env _ (NonRec binder rhs) body_usage
-  | isTyVar binder                     -- A type let; we don't gather usage info
+  | isTyCoVar binder                   -- A type let; we don't gather usage info
   = (body_usage, [NonRec binder rhs])
 
   | not (binder `usedIn` body_usage)    -- It's not mentioned
@@ -314,12 +315,13 @@ occAnalBind _ env (Rec pairs) body_usage
     rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
     
     make_node (bndr, rhs)
-       = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges)
+       = (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique bndr, out_edges)
        where
          (rhs_usage, rhs') = occAnalRhs env bndr rhs
-         all_rhs_usage = addRuleUsage rhs_usage bndr    -- Note [Rules are extra RHSs]
-         rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
-         out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
+         all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs]
+         rhs_fvs   = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+         out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars)
+          rule_vars = idRuleVars bndr      -- See Note [Rule dependency info]
         -- (a -> b) means a mentions b
         -- Given the usage details (a UFM that gives occ info for each free var of
         -- the RHS) we can get the list of free vars -- or rather their Int keys --
@@ -400,6 +402,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
     no_rules      = null init_rule_fvs
     init_rule_fvs = [(b, rule_fvs)
                     | b <- bndrs
+                   , isId b
                     , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
                     , not (isEmptyVarSet rule_fvs)]
 
@@ -529,6 +532,8 @@ reOrderCycle depth (bind : binds) pairs
 
     score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
     score (ND bndr rhs _ _, _, _)
+        | not (isId bndr) = 100            -- A type or cercion varialbe is never a loop breaker
+
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
                              -- Note [DFuns should not be loop breakers]
 
@@ -582,7 +587,8 @@ reOrderCycle depth (bind : binds) pairs
 
 makeLoopBreaker :: Bool -> Id -> Id
 -- Set the loop-breaker flag: see Note [Weak loop breakers]
-makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
+makeLoopBreaker weak bndr 
+  = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)
 \end{code}
 
 Note [Complexity of loop breaking]
@@ -730,7 +736,8 @@ occAnalRhs :: OccEnv
              -- Returned usage details includes any INLINE rhs
 
 occAnalRhs env id rhs
-  = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+  | isId id   = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+  | otherwise = (rhs_usage, rhs')
        -- Include occurrences for the "extra RHS" from a CoreUnfolding
   where
     (rhs_usage, rhs') = occAnal ctxt rhs
@@ -759,9 +766,11 @@ occAnalRhs env id rhs
 
 
 \begin{code}
-addRuleUsage :: UsageDetails -> Id -> UsageDetails
+addRuleUsage :: UsageDetails -> Var -> UsageDetails
 -- Add the usage from RULES in Id to the usage
-addRuleUsage usage id = addIdOccs usage (idRuleVars id)
+addRuleUsage usage var 
+  | isId var  = addIdOccs usage (idRuleVars var)
+  | otherwise = usage
         -- idRuleVars here: see Note [Rule dependency info]
 
 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
@@ -841,7 +850,7 @@ occAnal env app@(App _ _)
 --   (a) occurrences inside type lambdas only not marked as InsideLam
 --   (b) type variables not in environment
 
-occAnal env (Lam x body) | isTyVar x
+occAnal env (Lam x body) | isTyCoVar x
   = case occAnal env body of { (body_usage, body') ->
     (body_usage, Lam x body')
     }
@@ -1440,8 +1449,8 @@ mkAltEnv env scrut cb
   where
     pe  = occ_proxy env
     pe' = case scrut of
-             Var v           -> extendProxyEnv pe v IdCo     cb
-             Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
+             Var v           -> extendProxyEnv pe v (IdCo (idType v)) cb
+             Cast (Var v) co -> extendProxyEnv pe v (ACo co)          cb
             _other          -> trimProxyEnv pe [cb]
 
 -----------
@@ -1467,7 +1476,7 @@ trimProxyEnv (PE pe fvs) bndrs
                              
 -----------
 freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI IdCo     = emptyVarSet
+freeVarsCoI (IdCo t) = tyVarsOfType t
 freeVarsCoI (ACo co) = tyVarsOfType co
 \end{code}
 
@@ -1500,9 +1509,8 @@ addOneOcc usage id info
 emptyDetails :: UsageDetails
 emptyDetails = (emptyVarEnv :: UsageDetails)
 
-localUsedIn, usedIn :: Id -> UsageDetails -> Bool
-v `localUsedIn` details = v `elemVarEnv` details
-v `usedIn`      details =  isExportedId v || v `localUsedIn` details
+usedIn :: Id -> UsageDetails -> Bool
+v `usedIn` details = isExportedId v || v `elemVarEnv` details
 
 type IdWithOccInfo = Id
 
@@ -1536,7 +1544,7 @@ tagBinder usage binder
 
 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
 setBinderOcc usage bndr
-  | isTyVar bndr      = bndr
+  | isTyCoVar bndr    = bndr
   | isExportedId bndr = case idOccInfo bndr of
                           NoOccInfo -> bndr
                           _         -> setIdOccInfo bndr NoOccInfo
index 8c99fcb..ef0c7f2 100644 (file)
@@ -535,7 +535,7 @@ lvlBind :: TopLevelFlag             -- Used solely to decide whether to clone
        -> LvlM (LevelledBind, LevelEnv)
 
 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
-  |  isTyVar bndr              -- Don't do anything for TyVar binders
+  |  isTyCoVar bndr            -- Don't do anything for TyVar binders
                                --   (simplifier gets rid of them pronto)
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)
@@ -845,7 +845,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
                   (False, True) -> False
                   _             -> v1 <= v2    -- Same family
 
-    is_tv v = isTyVar v && not (isCoVar v)
+    is_tv v = isTyCoVar v && not (isCoVar v)
 
     uniq :: [Var] -> [Var]
        -- Remove adjacent duplicates; the sort will have brought them together
index 2a41a0e..316382b 100644 (file)
@@ -41,7 +41,6 @@ import FamInstEnv
 import Id
 import DataCon
 import TyCon           ( tyConDataCons )
-import Class           ( classSelIds )
 import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )
 import VarSet
 import VarEnv
@@ -71,64 +70,31 @@ import Maybes
 %************************************************************************
 
 \begin{code}
-core2core :: HscEnv
-         -> ModGuts
-         -> IO ModGuts
+core2core :: HscEnv -> ModGuts -> IO ModGuts
+core2core hsc_env guts 
+  = do { us <- mkSplitUniqSupply 's'
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ 
+                           doCorePasses (getCoreToDo dflags) guts
 
-core2core hsc_env guts = do
-    let dflags = hsc_dflags hsc_env
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+             "Grand total simplifier statistics"
+             (pprSimplCount stats)
 
-    us <- mkSplitUniqSupply 's'
-    let (cp_us, ru_us) = splitUniqSupply us
-
-    -- COMPUTE THE RULE BASE TO USE
-    -- See Note [Overall plumbing for rules] in Rules.lhs
-    (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
-
-    -- Get the module out of the current HscEnv so we can retrieve it from the monad.
+       ; return guts2 }
+  where
+    dflags         = hsc_dflags hsc_env
+    home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
+    hpt_rule_base  = mkRuleBase home_pkg_rules
+    mod            = mg_module guts
+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
     -- This is very convienent for the users of the monad (e.g. plugins do not have to
     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
-    let mod = mg_module guts
-    (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
-        -- FIND BUILT-IN PASSES
-        let builtin_core_todos = getCoreToDo dflags
-
-        -- DO THE BUSINESS
-        doCorePasses builtin_core_todos guts1
-
-    Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
-        "Grand total simplifier statistics"
-        (pprSimplCount stats)
-
-    return guts2
 
 
 type CorePass = CoreToDo
 
-simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-            -> CoreExpr
-            -> IO CoreExpr
--- simplifyExpr is called by the driver to simplify an
--- expression typed in at the interactive prompt
---
--- Also used by Template Haskell
-simplifyExpr dflags expr
-  = do {
-       ; Err.showPass dflags "Simplify"
-
-       ; us <-  mkSplitUniqSupply 's'
-
-       ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                simplExprGently simplEnvForGHCi expr
-
-       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
-                       (pprCoreExpr expr')
-
-       ; return expr'
-       }
-
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
 doCorePasses passes guts 
   = foldM do_pass guts passes
@@ -250,125 +216,33 @@ observe do_pass = doPassM $ \binds -> do
 
 %************************************************************************
 %*                                                                     *
-       Dealing with rules
+       Gentle simplification
 %*                                                                     *
 %************************************************************************
 
--- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
--- It attaches those rules that are for local Ids to their binders, and
--- returns the remainder attached to Ids in an IdSet.  
-
 \begin{code}
-prepareRules :: HscEnv 
-            -> ModGuts
-            -> UniqSupply
-            -> IO (RuleBase,           -- Rule base for imported things, incl
-                                       -- (a) rules defined in this module (orphans)
-                                       -- (b) rules from other modules in home package
-                                       -- but not things from other packages
-
-                   ModGuts)            -- Modified fields are 
-                                       --      (a) Bindings have rules attached,
-                                       --              and INLINE rules simplified
-                                       --      (b) Rules are now just orphan rules
-
-prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
-            guts@(ModGuts { mg_binds = binds, mg_deps = deps 
-                          , mg_rules = local_rules, mg_rdr_env = rdr_env })
-            us 
-  = do { us <- mkSplitUniqSupply 'w'
-
-       ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
-               -- from the local binders, to avoid warnings from Simplify.simplVar
-             local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
-             env              = setInScopeSet simplEnvForRules local_ids 
-             (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                mapM (simplRule env) local_rules
-
-       ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
-
-             home_pkg_rules = hptRules hsc_env (dep_mods deps)
-             hpt_rule_base  = mkRuleBase home_pkg_rules
-             binds_w_rules  = updateBinders rules_for_locals binds
-
-
-       ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
-               (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
-                vcat [text "Local rules for local Ids", pprRules simpl_rules,
-                      blankLine,
-                      text "Local rules for imported Ids", pprRuleBase hpt_rule_base])
-
-       ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, 
-                                       mg_rules = rules_for_imps })
-    }
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+            -> CoreExpr
+            -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
+simplifyExpr dflags expr
+  = do {
+       ; Err.showPass dflags "Simplify"
 
--- Note [Attach rules to local ids]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Find the rules for locally-defined Ids; then we can attach them
--- to the binders in the top-level bindings
--- 
--- Reason
---     - It makes the rules easier to look up
---     - It means that transformation rules and specialisations for
---       locally defined Ids are handled uniformly
---     - It keeps alive things that are referred to only from a rule
---       (the occurrence analyser knows about rules attached to Ids)
---     - It makes sure that, when we apply a rule, the free vars
---       of the RHS are more likely to be in scope
---     - The imported rules are carried in the in-scope set
---       which is extended on each iteration by the new wave of
---       local binders; any rules which aren't on the binding will
---       thereby get dropped
-
-updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
-updateBinders rules_for_locals binds
-  = map update_bind binds
-  where
-    local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
-
-    update_bind (NonRec b r) = NonRec (add_rules b) r
-    update_bind (Rec prs)    = Rec (mapFst add_rules prs)
-
-       -- See Note [Attach rules to local ids]
-       -- NB: the binder might have some existing rules,
-       -- arising from specialisation pragmas
-    add_rules bndr
-       | Just rules <- lookupNameEnv local_rules (idName bndr)
-       = bndr `addIdSpecialisations` rules
-       | otherwise
-       = bndr
-\end{code}
+       ; us <-  mkSplitUniqSupply 's'
 
-Note [Simplifying the left-hand side of a RULE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must do some gentle simplification on the lhs (template) of each
-rule.  The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
-       fold k z (build (/\a. g a))  ==>  ...
-This doesn't match unless you do eta reduction on the build argument.
-Similarly for a LHS like
-       augment g (build h) 
-we do not want to get
-       augment (\a. g a) (build h)
-otherwise we don't match when given an argument like
-       augment (\a. h a a) (build h)
-
-The simplifier does indeed do eta reduction (it's in
-Simplify.completeLam) but only if -O is on.
+       ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+                                simplExprGently simplEnvForGHCi expr
 
-\begin{code}
-simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
-simplRule env rule@(BuiltinRule {})
-  = return rule
-simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
-  = do (env, bndrs') <- simplBinders env bndrs
-       args' <- mapM (simplExprGently env) args
-       rhs' <- simplExprGently env rhs
-       return (rule { ru_bndrs = bndrs', ru_args = args'
-                    , ru_rhs = occurAnalyseExpr rhs' })
-\end{code}
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+                       (pprCoreExpr expr')
+
+       ; return expr'
+       }
 
-\begin{code}
 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 -- Simplifies an expression 
 --     does occurrence analysis, then simplification
index b341b87..10b0003 100644 (file)
@@ -528,7 +528,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- The substitution is extended only if the variable is cloned, because
 -- we *don't* need to use it to track occurrence info.
 simplBinder env bndr
-  | isTyVar bndr  = do { let (env', tv) = substTyVarBndr env bndr
+  | isTyCoVar bndr  = do       { let (env', tv) = substTyVarBndr env bndr
                        ; seqTyVar tv `seq` return (env', tv) }
   | otherwise     = do { let (env', id) = substIdBndr env bndr
                        ; seqId id `seq` return (env', id) }
index 96857a3..d1c5cef 100644 (file)
@@ -36,7 +36,7 @@ import qualified CoreSubst
 import PprCore
 import CoreFVs
 import CoreUtils
-import CoreArity       ( etaExpand, exprEtaExpandArity )
+import CoreArity
 import CoreUnfold
 import Name
 import Id
@@ -1039,7 +1039,7 @@ mkLam _env bndrs body
           ; return etad_lam }
 
       | dopt Opt_DoLambdaEtaExpansion dflags,
-       not (all isTyVar bndrs) -- Don't eta expand type abstractions
+       not (all isTyCoVar bndrs) -- Don't eta expand type abstractions
       = do { let body' = tryEtaExpansion dflags body
           ; return (mkLams bndrs body') }
    
@@ -1085,7 +1085,7 @@ because the latter is not well-kinded.
 
 {-     Sept 01: I'm experimenting with getting the
        full laziness pass to float out past big lambdsa
- | all isTyVar bndrs,  -- Only for big lambdas
+ | all isTyCoVar bndrs,        -- Only for big lambdas
    contIsRhs cont      -- Only try the rhs type-lambda floating
                        -- if this is indeed a right-hand side; otherwise
                        -- we end up floating the thing out, only for float-in
@@ -1097,100 +1097,6 @@ because the latter is not well-kinded.
 
 %************************************************************************
 %*                                                                     *
-               Eta reduction
-%*                                                                     *
-%************************************************************************
-
-Note [Eta reduction conditions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We try for eta reduction here, but *only* if we get all the way to an
-trivial expression.  We don't want to remove extra lambdas unless we
-are going to avoid allocating this thing altogether.
-
-There are some particularly delicate points here:
-
-* Eta reduction is not valid in general:  
-       \x. bot  /=  bot
-  This matters, partly for old-fashioned correctness reasons but,
-  worse, getting it wrong can yield a seg fault. Consider
-       f = \x.f x
-       h y = case (case y of { True -> f `seq` True; False -> False }) of
-               True -> ...; False -> ...
-
-  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
-  says f=bottom, and replaces the (f `seq` True) with just
-  (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it
-  *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands 
-  the definition again, so that it does not termninate after all.
-  Result: seg-fault because the boolean case actually gets a function value.
-  See Trac #1947.
-
-  So it's important to to the right thing.
-
-* Note [Arity care]: we need to be careful if we just look at f's
-  arity. Currently (Dec07), f's arity is visible in its own RHS (see
-  Note [Arity robustness] in SimplEnv) so we must *not* trust the
-  arity when checking that 'f' is a value.  Otherwise we will
-  eta-reduce
-      f = \x. f x
-  to
-      f = f
-  Which might change a terminiating program (think (f `seq` e)) to a 
-  non-terminating one.  So we check for being a loop breaker first.
-
-  However for GlobalIds we can look at the arity; and for primops we
-  must, since they have no unfolding.  
-
-* Regardless of whether 'f' is a value, we always want to 
-  reduce (/\a -> f a) to f
-  This came up in a RULE: foldr (build (/\a -> g a))
-  did not match          foldr (build (/\b -> ...something complex...))
-  The type checker can insert these eta-expanded versions,
-  with both type and dictionary lambdas; hence the slightly 
-  ad-hoc isDictId
-
-* Never *reduce* arity. For example
-      f = \xy. g x y
-  Then if h has arity 1 we don't want to eta-reduce because then
-  f's arity would decrease, and that is bad
-
-These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
-Alas.
-
-\begin{code}
-tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
-tryEtaReduce bndrs body 
-  = go (reverse bndrs) body
-  where
-    incoming_arity = count isId bndrs
-
-    go (b : bs) (App fun arg) | ok_arg b arg = go bs fun       -- Loop round
-    go []       fun           | ok_fun fun   = Just fun                -- Success!
-    go _        _                           = Nothing          -- Failure!
-
-       -- Note [Eta reduction conditions]
-    ok_fun (App fun (Type ty)) 
-       | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
-       =  ok_fun fun
-    ok_fun (Var fun_id)
-       =  not (fun_id `elem` bndrs)
-       && (ok_fun_id fun_id || all ok_lam bndrs)
-    ok_fun _fun = False
-
-    ok_fun_id fun = fun_arity fun >= incoming_arity
-
-    fun_arity fun            -- See Note [Arity care]
-       | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
-       | otherwise = idArity fun             
-
-    ok_lam v = isTyVar v || isDictId v
-
-    ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
                Eta expansion
 %*                                                                     *
 %************************************************************************
@@ -1337,7 +1243,7 @@ abstractFloats main_tvs body_env body
        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
        tvs_here | any isCoVar main_tvs = main_tvs      -- Note [Abstract over coercions]
                 | otherwise 
-                = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+                = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
        
                -- Abstract only over the type variables free in the rhs
                -- wrt which the new binding is abstracted.  But the naive
@@ -1529,16 +1435,17 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
   , Just all_cons <- tyConDataCons_maybe tycon
-  , not (null all_cons)                -- This is a tricky corner case.  If the data type has no constructors,
-                               -- which GHC allows, then the case expression will have at most a default
-                               -- alternative.  We don't want to eliminate that alternative, because the
-                               -- invariant is that there's always one alternative.  It's more convenient
-                               -- to leave     
-                               --      case x of { DEFAULT -> e }     
-                               -- as it is, rather than transform it to
-                               --      error "case cant match"
-                               -- which would be quite legitmate.  But it's a really obscure corner, and
-                               -- not worth wasting code on.
+  , not (null all_cons)        
+       -- This is a tricky corner case.  If the data type has no constructors,
+       -- which GHC allows, then the case expression will have at most a default
+       -- alternative.  We don't want to eliminate that alternative, because the
+       -- invariant is that there's always one alternative.  It's more convenient
+       -- to leave     
+       --      case x of { DEFAULT -> e }     
+       -- as it is, rather than transform it to
+       --      error "case cant match"
+       -- which would be quite legitmate.  But it's a really obscure corner, and
+       -- not worth wasting code on.
   , let imposs_data_cons = [con | DataAlt con <- imposs_cons]  -- We now know it's a data type 
        impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
   = case filterOut impossible all_cons of
@@ -1554,9 +1461,12 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
 
        _ -> return [(DEFAULT, [], deflt_rhs)]
 
-  | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+  | debugIsOn, isAlgTyCon tycon
+  , null (tyConDataCons tycon)
+  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
        -- Check for no data constructors
-        -- This can legitimately happen for type families, so don't report that
+        -- This can legitimately happen for abstract types and type families,
+        -- so don't report that
   = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
         $ return [(DEFAULT, [], deflt_rhs)]
 
index ec7e190..fd8981a 100644 (file)
@@ -877,7 +877,7 @@ simplExprF' env expr@(Lam _ _) cont
     n_params = length bndrs
     (bndrs, body) = collectBinders expr
     zap | n_args >= n_params = \b -> b
-        | otherwise          = \b -> if isTyVar b then b
+        | otherwise          = \b -> if isTyCoVar b then b
                                      else zapLamIdInfo b
         -- NB: we count all the args incl type args
         -- so we must count all the binders (incl type lambdas)
@@ -1081,7 +1081,7 @@ simplNonRecE :: SimplEnv
        -- First deal with type applications and type lets
        --   (/\a. e) (Type ty)   and   (let a = Type ty in e)
 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
-  = ASSERT( isTyVar bndr )
+  = ASSERT( isTyCoVar bndr )
     do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
        ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 
@@ -1095,7 +1095,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                      (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = ASSERT( not (isTyVar bndr) )
+  = ASSERT( not (isTyCoVar bndr) )
     do  { (env1, bndr1) <- simplNonRecBndr env bndr
         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
@@ -1137,7 +1137,7 @@ simplNote env (CoreNote s) e cont
 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
 -- Look up an InVar in the environment
 simplVar env var
-  | isTyVar var 
+  | isTyCoVar var 
   = return (Type (substTyVar env var))
   | otherwise
   = case substId env var of
@@ -1768,7 +1768,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
         = go vs the_strs
         where
           go [] [] = []
-          go (v:vs') strs | isTyVar v = v : go vs' strs
+          go (v:vs') strs | isTyCoVar v = v : go vs' strs
           go (v:vs') (str:strs)
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
@@ -1843,7 +1843,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
     bind_args env' [] _  = return env'
 
     bind_args env' (b:bs') (Type ty : args)
-      = ASSERT( isTyVar b )
+      = ASSERT( isTyCoVar b )
         bind_args (extendTvSubst env' b ty) bs' args
 
     bind_args env' (b:bs') (arg : args)
@@ -2030,7 +2030,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
                          | otherwise              = bndrs' ++ [case_bndr_w_unf]
              
               abstract_over bndr
-                  | isTyVar bndr = True -- Abstract over all type variables just in case
+                  | isTyCoVar bndr = True -- Abstract over all type variables just in case
                   | otherwise    = not (isDeadBinder bndr)
                         -- The deadness info on the new Ids is preserved by simplBinders
 
index 1219d1c..87999a4 100644 (file)
@@ -58,15 +58,15 @@ import Data.List
 
 Note [Overall plumbing for rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-* The ModGuts initially contains mg_rules :: [CoreRule] of rules
-  declared in this module. During the core-to-core pipeline,
-  locally-declared rules for locally-declared Ids are attached to the
-  IdInfo for that Id, so the mg_rules field of ModGuts now only
-  contains locally-declared rules for *imported* Ids.  TidyPgm restores
-  the original setup, so that the ModGuts again has *all* the
-  locally-declared rules.  See Note [Attach rules to local ids] in
-  SimplCore
+* After the desugarer:
+   - The ModGuts initially contains mg_rules :: [CoreRule] of
+     locally-declared rules for imported Ids.  
+   - Locally-declared rules for locally-declared Ids are attached to
+     the IdInfo for that Id.  See Note [Attach rules to local ids] in
+     DsBinds
+* TidyPgm strips off all the rules from local Ids and adds them to
+  mg_rules, so that the ModGuts has *all* the locally-declared rules.
 
 * The HomePackageTable contains a ModDetails for each home package
   module.  Each contains md_rules :: [CoreRule] of rules declared in
@@ -500,7 +500,7 @@ matchN id_unf in_scope tmpl_vars tmpl_es target_es
 
     lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
     lookup_tmpl tv_subst id_subst tmpl_var'
-       | isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
+       | isTyCoVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
                                Just ty         -> Type ty
                                Nothing         -> unbound tmpl_var'
        | otherwise         = case lookupVarEnv id_subst tmpl_var' of
index 84f8698..a9e9136 100644 (file)
@@ -672,7 +672,7 @@ extendCaseBndrs env case_bndr con alt_bndrs
        --      Var v  -> extendValEnv env1 v cval
        --      _other -> env1
  where
-   zap v | isTyVar v = v               -- See NB2 above
+   zap v | isTyCoVar v = v             -- See NB2 above
          | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of
@@ -936,7 +936,7 @@ scExpr' env (Case scrut b ty alts)
           ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
-  | isTyVar bndr       -- Type-lets may be created by doBeta
+  | isTyCoVar bndr     -- Type-lets may be created by doBeta
   = scExpr' (extendScSubst env bndr rhs) body
 
   | otherwise             -- Note [Local let bindings]
@@ -1398,7 +1398,7 @@ callToPats env bndr_occs (con_env, args)
                -- at the call site
                -- See Note [Shadowing] at the top
                
-             (tvs, ids) = partition isTyVar qvars
+             (tvs, ids) = partition isTyCoVar qvars
              qvars'     = tvs ++ ids
                -- Put the type variables first; the type of a term
                -- variable may mention a type variable
@@ -1572,7 +1572,7 @@ isValue env (Var v)
        -- as well, for let-bound constructors!
 
 isValue env (Lam b e)
-  | isTyVar b = case isValue env e of
+  | isTyCoVar b = case isValue env e of
                  Just _  -> Just LambdaVal
                  Nothing -> Nothing
   | otherwise = Just LambdaVal
index edda603..370393b 100644 (file)
@@ -445,7 +445,7 @@ mkStgAltType bndr alts
    _is_poly_alt_tycon tc
        =  isFunTyCon tc
         || isPrimTyCon tc   -- "Any" is lifted but primitive
-       || isOpenTyCon tc   -- Type family; e.g. arising from strict
+       || isFamilyTyCon tc   -- Type family; e.g. arising from strict
                            -- function application where argument has a
                            -- type-family type
 
@@ -1120,7 +1120,7 @@ myCollectArgs expr
     go (Cast e _)       as = go e as
     go (Note _ e)       as = go e as
     go (Lam b e)        as
-       | isTyVar b         = go e as   -- Note [Collect args]
+       | isTyCoVar b         = go e as -- Note [Collect args]
     go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}
 
index 2a160cd..32986e5 100644 (file)
@@ -186,7 +186,7 @@ dmdAnal sigs dmd (App fun arg)      -- Non-type arguments
     (res_ty `bothType` arg_ty, App fun' arg')
 
 dmdAnal sigs dmd (Lam var body)
-  | isTyVar var
+  | isTyCoVar var
   = let   
        (body_ty, body') = dmdAnal sigs dmd body
     in
@@ -765,7 +765,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
 -- The returned var is annotated with demand info
 -- No effect on the argument demands
 annotateBndr dmd_ty@(DmdType fv ds res) var
-  | isTyVar var = (dmd_ty, var)
+  | isTyCoVar var = (dmd_ty, var)
   | otherwise   = (DmdType fv' ds res, setIdDemandInfo var dmd)
   where
     (fv', dmd) = removeFV fv var res
index 611c4d4..40a2a26 100644 (file)
@@ -336,7 +336,7 @@ mkWWstr (arg : args) = do
 --       brings into scope wrap_arg (via lets)
 mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 mkWWstr_one arg
-  | isTyVar arg
+  | isTyCoVar arg
   = return ([arg],  nop_fn, nop_fn)
 
   | otherwise
index b09f9a5..e2da795 100644 (file)
@@ -2,7 +2,7 @@ The @FamInst@ type: family instance heads
 
 \begin{code}
 module FamInst ( 
-        checkFamInstC