Commit 07f3c0c8 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

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.
parent bb394e57
......@@ -25,6 +25,7 @@ import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
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,
......@@ -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 (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 }
......
......@@ -18,10 +18,9 @@ import CoreSubst ( Subst, mkSubst, substExpr )
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 Unify ( coreRefineTys )
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
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
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
......
......@@ -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 (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)
......@@ -688,7 +690,6 @@ specExpr subst (Let bind body)
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}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment