Massive patch for the first months work adding System FC to GHC #4

Broken up massive patch -=chak
Original log message:
This is (sadly) all done in one patch to avoid Darcs bugs.
It's not complete work... more FC stuff to come.  A compiler
using just this patch will fail dismally.

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 105d248..c8f35ea 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -14,19 +14,19 @@ import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculatio
 import CoreFVs ( exprFreeVars )
 import CoreLint        ( endPass )
 import CoreSyn
-import Type    ( Type, applyTy, splitFunTy_maybe, 
-                 isUnLiftedType, isUnboxedTupleType, seqType )
+import Type    ( Type, applyTy, 
+                  splitFunTy_maybe, isUnLiftedType, isUnboxedTupleType, seqType )
+import Coercion ( coercionKind )
 import TyCon   ( TyCon, tyConDataCons )
 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
 import Var     ( Var, Id, setVarUnique )
 import VarSet
 import VarEnv
-import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
-                 isFCallId, isGlobalId, 
-                 isLocalId, hasNoBinding, idNewStrictness, 
+import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, 
+                 isFCallId, isGlobalId, isLocalId, hasNoBinding, idNewStrictness, 
                  isPrimOpId_maybe
                )
-import DataCon   ( isVanillaDataCon, dataConWorkId )
+import DataCon   ( dataConWorkId )
 import PrimOp    ( PrimOp( DataToTagOp ) )
 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
@@ -48,7 +48,8 @@ The goal of this pass is to prepare for code generation.
 
 1.  Saturate constructor and primop applications.
 
-2.  Convert to A-normal form:
+2.  Convert to A-normal form; that is, function arguments
+    are always variables.
 
     * Use case for strict arguments:
        f E ==> case E of x -> f x
@@ -338,6 +339,7 @@ exprIsTrivial (Lit lit)                    = True
 exprIsTrivial (App e arg)             = isTypeArg arg && exprIsTrivial e
 exprIsTrivial (Note (SCC _) e)                = False
 exprIsTrivial (Note _ e)              = exprIsTrivial e
+exprIsTrivial (Cast e co)              = exprIsTrivial e
 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 exprIsTrivial other                   = False
 
@@ -387,6 +389,10 @@ corePrepExprFloat env (Note other_note expr)
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr') ->
     returnUs (floats, Note other_note expr')
 
+corePrepExprFloat env (Cast expr co)
+  = corePrepExprFloat env expr         `thenUs` \ (floats, expr') ->
+    returnUs (floats, Cast expr' co)
+
 corePrepExprFloat env expr@(Lam _ _)
   = cloneBndrs env bndrs               `thenUs` \ (env', bndrs') ->
     corePrepAnExpr env' body           `thenUs` \ body' ->
@@ -406,10 +412,7 @@ corePrepExprFloat env (Case scrut bndr ty alts)
     returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
   where
     sat_alt env (con, bs, rhs)
-         = let 
-               env1 = setGadt env con
-           in
-           cloneBndrs env1 bs          `thenUs` \ (env2, bs') ->
+         = cloneBndrs env bs           `thenUs` \ (env2, bs') ->
            corePrepAnExpr env2 rhs     `thenUs` \ rhs1 ->
            deLam rhs1                  `thenUs` \ rhs2 ->
            returnUs (con, bs', rhs2)
@@ -475,11 +478,11 @@ corePrepExprFloat env expr@(App _ _)
                -- Here, we can't evaluate the arg strictly, because this 
                -- partial application might be seq'd
 
-
-    collect_args (Note (Coerce ty1 ty2) fun) depth
-        = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
-         returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
-
+    collect_args (Cast fun co) depth
+        = let (_ty1,ty2) = coercionKind co in
+          collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
+         returnUs (Cast fun' co, hd, ty2, floats, ss)
+          
     collect_args (Note note fun) depth
        | ignore_note note      -- Drop these notes altogether
                                -- They aren't used by the code generator
@@ -675,6 +678,9 @@ etaExpandRhs bndr rhs
 -- ---------------------------------------------------------------------------
 
 deLam :: CoreExpr -> UniqSM CoreExpr
+-- Takes an expression that may be a lambda, 
+-- and returns one that definitely isn't:
+--     (\x.e) ==>  let f = \x.e in f
 deLam expr = 
   deLamFloat expr   `thenUs` \ (floats, expr) ->
   mkBinds floats expr
@@ -689,6 +695,10 @@ deLamFloat (Note n expr)
     deLamFloat expr    `thenUs` \ (floats, expr') ->
     returnUs (floats, Note n expr')
 
+deLamFloat (Cast e co)
+  = deLamFloat e       `thenUs` \ (floats, e') ->
+    returnUs (floats, Cast e' co)
+
 deLamFloat expr 
   | null bndrs = returnUs (emptyFloats, expr)
   | otherwise 
@@ -703,7 +713,8 @@ deLamFloat expr
 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 -- But the simplifier only eta reduces if that leaves something
 -- trivial (like f, or f Int).  But for deLam it would be enough to
--- get to a partial application, like (map f).
+-- get to a partial application:
+--     \xs. map f xs ==> map f
 
 tryEta bndrs expr@(App _ _)
   | ok_to_eta_reduce f &&
@@ -780,38 +791,18 @@ onceDem = RhsDemand False True   -- used at most once
 -- ---------------------------------------------------------------------------
 
 data CorePrepEnv = CPE (IdEnv Id)      -- Clone local Ids
-                      Bool             -- True <=> inside a GADT case; see Note [GADT]
-
--- Note [GADT]
---
--- Be careful with cloning inside GADTs.  For example, 
---     /\a. \f::a. \x::T a. case x of { T -> f True; ... }
--- The case on x may refine the type of f to be a function type.
--- Without this type refinement, exprType (f True) may simply fail,
--- which is bad.  
---
--- Solution: remember when we are inside a potentially-type-refining case,
---          and in that situation use the type from the old occurrence
---          when looking up occurrences
 
 emptyCorePrepEnv :: CorePrepEnv
-emptyCorePrepEnv = CPE emptyVarEnv False
+emptyCorePrepEnv = CPE emptyVarEnv
 
 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
-extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt
+extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
 
 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
--- See Note [GADT] above
-lookupCorePrepEnv (CPE env gadt) id
+lookupCorePrepEnv (CPE env) id
   = case lookupVarEnv env id of
-       Nothing              -> id
-       Just id' | gadt      -> setIdType id' (idType id)
-                | otherwise -> id'
-
-setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv
-setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True
-setGadt env               other                                                = env
-
+       Nothing  -> id
+       Just id' -> id'
 
 ------------------------------------------------------------------------------
 -- Cloning binders

diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 6f13740..7b80eac 100644 (file)
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -11,8 +11,7 @@ module CoreTidy (
 
 import CoreSyn
 import CoreUtils       ( exprArity )
-import Unify           ( coreRefineTys )
-import DataCon         ( DataCon, isVanillaDataCon )
+import DataCon         ( DataCon )
 import Id              ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
                          idType, setIdType )
 import IdInfo          ( setArityInfo, vanillaIdInfo,
@@ -57,11 +56,12 @@ tidyBind env (Rec prs)
 
 ------------  Expressions  --------------
 tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
-tidyExpr env (Var v)           =  Var (tidyVarOcc env v)
-tidyExpr env (Type ty)         =  Type (tidyType env ty)
-tidyExpr env (Lit lit)         =  Lit lit
-tidyExpr env (App f a)         =  App (tidyExpr env f) (tidyExpr env a)
-tidyExpr env (Note n e) =  Note (tidyNote env n) (tidyExpr env e)
+tidyExpr env (Var v)            =  Var (tidyVarOcc env v)
+tidyExpr env (Type ty)          =  Type (tidyType env ty)
+tidyExpr env (Lit lit)          =  Lit lit
+tidyExpr env (App f a)          =  App (tidyExpr env f) (tidyExpr env a)
+tidyExpr env (Note n e)  =  Note (tidyNote env n) (tidyExpr env e)
+tidyExpr env (Cast e co) =  Cast (tidyExpr env e) (tidyType env co)
 
 tidyExpr env (Let b e) 
   = tidyBind env b     =: \ (env', b') ->
@@ -77,42 +77,11 @@ tidyExpr env (Lam b e)
     Lam b (tidyExpr env' e)
 
 ------------  Case alternatives  --------------
-tidyAlt case_bndr env (DataAlt con, vs, rhs)
-  | not (isVanillaDataCon con) -- GADT case
-  = tidyBndrs env tvs          =: \ (env1, tvs') ->
-    let 
-       env2 = refineTidyEnv env1 con tvs' scrut_ty
-    in
-    tidyBndrs env2 ids         =: \ (env3, ids') ->
-    (DataAlt con, tvs' ++ ids', tidyExpr env3 rhs)
-  where 
-    (tvs, ids) = span isTyVar vs
-    scrut_ty = idType case_bndr
-
 tidyAlt case_bndr env (con, vs, rhs)
   = tidyBndrs env vs   =: \ (env', vs) ->
     (con, vs, tidyExpr env' rhs)
 
-refineTidyEnv :: TidyEnv -> DataCon -> [TyVar] -> Type -> TidyEnv
--- Refine the TidyEnv in the light of the type refinement from coreRefineTys
-refineTidyEnv tidy_env@(occ_env, var_env)  con tvs scrut_ty
-  = case coreRefineTys con tvs scrut_ty of
-       Nothing -> tidy_env
-       Just (tv_subst, all_bound_here)
-           | all_bound_here    -- Local type refinement only
-           -> tidy_env
-           | otherwise         -- Apply the refining subst to the tidy env
-                               -- This ensures that occurences have the most refined type
-                               -- And that means that exprType will work right everywhere
-           -> (occ_env, mapVarEnv (refine subst) var_env)
-           where
-             subst = mkOpenTvSubst tv_subst
-  where
-    refine subst var | isId var  = setIdType var (substTy subst (idType var)) 
-                    | otherwise = var
-
 ------------  Notes  --------------
-tidyNote env (Coerce t1 t2)  = Coerce (tidyType env t1) (tidyType env t2)
 tidyNote env note            = note
 
 ------------  Rules  --------------