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

Fri Aug  4 18:13:56 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Massive patch for the first months work adding System FC to GHC #31

  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/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index c7edd8f..35a0bdd 100644 (file)
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -25,6 +25,7 @@ import CoreUnfold     ( isCheapUnfolding, unfoldingTemplate )
 import CoreUtils       ( tcEqExprX )
 import PprCore         ( pprRules )
 import Type            ( TvSubstEnv )
 import CoreUtils       ( tcEqExprX )
 import PprCore         ( pprRules )
 import Type            ( TvSubstEnv )

+import Coercion         ( coercionKind )

 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id              ( Id, idUnfolding, isLocalId, isGlobalId, idName,
 import TcType          ( tcSplitTyConApp_maybe )
 import CoreTidy                ( tidyRules )
 import Id              ( Id, idUnfolding, isLocalId, isGlobalId, idName,

@@ -468,7 +469,9 @@ match menv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)
 match menv subst (Type ty1) (Type ty2)
   = match_ty menv subst ty1 ty2
 
 match menv subst (Type ty1) (Type ty2)
   = match_ty menv subst ty1 ty2
 

-match menv subst (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2)
+match menv subst (Cast e1 co1) (Cast e2 co2)
+  | (from1, to1) <- coercionKind co1
+  , (from2, to2) <- coercionKind co2

   = do { subst1 <- match_ty menv subst  to1   to2
        ; subst2 <- match_ty menv subst1 from1 from2
        ; match menv subst2 e1 e2 }
   = do { subst1 <- match_ty menv subst  to1   to2
        ; subst2 <- match_ty menv subst1 from1 from2
        ; match menv subst2 e1 e2 }

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 65835d9..46cea9b 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -18,10 +18,9 @@ import CoreSubst     ( Subst, mkSubst, substExpr )
 import CoreTidy                ( tidyRules )
 import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )
 import CoreTidy                ( tidyRules )
 import PprCore         ( pprRules )
 import WwLib           ( mkWorkerArgs )

-import DataCon         ( dataConRepArity, isVanillaDataCon, dataConTyVars )
+import DataCon         ( dataConRepArity, dataConTyVars )

 import Type            ( Type, tyConAppArgs, tyVarsOfTypes )
 import Rules           ( matchN )
 import Type            ( Type, tyConAppArgs, tyVarsOfTypes )
 import Rules           ( matchN )

-import Unify           ( coreRefineTys )

 import Id              ( Id, idName, idType, isDataConWorkId_maybe, 
                          mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
 import Var             ( Var )
 import Id              ( Id, idName, idType, isDataConWorkId_maybe, 
                          mkUserLocal, mkSysLocal, idUnfolding, isLocalId )
 import Var             ( Var )

@@ -483,28 +482,11 @@ extendCaseBndrs env case_bndr scrut con alt_bndrs
                  Var v -> lookupVarEnv cur_scope v `orElse` Other
                  other -> Other
 
                  Var v -> lookupVarEnv cur_scope v `orElse` Other
                  other -> Other
 

-    extend_data_con data_con
-       | isVanillaDataCon data_con = extendCons env1 scrut case_bndr (CV con vanilla_args)
-       | otherwise                 = extendCons env2 scrut case_bndr (CV con gadt_args)
-               -- Note env2 for GADTs
+    extend_data_con data_con = 
+      extendCons env1 scrut case_bndr (CV con vanilla_args)

        where
        where

-    

            vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
            vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++

-                          map varToCoreExpr alt_bndrs
-
-           gadt_args = map (substExpr subst . varToCoreExpr) alt_bndrs
-               -- This call generates some bogus warnings from substExpr,
-               -- because it's inconvenient to put all the Ids in scope
-               -- Will be fixed when we move to FC
-
-           (alt_tvs, _) = span isTyVar alt_bndrs
-           Just (tv_subst, is_local) = coreRefineTys data_con alt_tvs (idType case_bndr)
-           subst = mkSubst in_scope tv_subst emptyVarEnv       -- No Id substitition
-           in_scope = mkInScopeSet (tyVarsOfTypes (varEnvElts tv_subst))
-       
-           env2 | is_local  = env1
-                | otherwise = env1 { cons = refineConstrEnv subst (cons env) }
-
+                          varsToCoreExprs alt_bndrs

 
 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 extendCons env scrut case_bndr val
 
 extendCons :: ScEnv -> CoreExpr -> Id -> ConValue -> ScEnv
 extendCons env scrut case_bndr val

diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 3646f91..fa9d253 100644 (file)
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -624,7 +624,9 @@ specExpr :: Subst -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
 specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
 specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
 specExpr subst (Lit lit) = returnSM (Lit lit,                emptyUDs)
 specExpr subst (Type ty) = returnSM (Type (substTy subst ty), emptyUDs)
 specExpr subst (Var v)   = returnSM (specVar subst v,         emptyUDs)
 specExpr subst (Lit lit) = returnSM (Lit lit,                emptyUDs)

-
+specExpr subst (Cast e co) =
+  specExpr subst e              `thenSM` \ (e', uds) ->
+  returnSM ((Cast e' (substTy subst co)), uds)

 specExpr subst (Note note body)
   = specExpr subst body        `thenSM` \ (body', uds) ->
     returnSM (Note (specNote subst note) body', uds)
 specExpr subst (Note note body)
   = specExpr subst body        `thenSM` \ (body', uds) ->
     returnSM (Note (specNote subst note) body', uds)

@@ -688,7 +690,6 @@ specExpr subst (Let bind body)
     returnSM (foldr Let body' binds', uds)
 
 -- Must apply the type substitution to coerceions
     returnSM (foldr Let body' binds', uds)
 
 -- Must apply the type substitution to coerceions

-specNote subst (Coerce t1 t2) = Coerce (substTy subst t1) (substTy subst t2)

 specNote subst note          = note
 \end{code}
 
 specNote subst note          = note
 \end{code}