Commit f94350a0 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

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.
parent afbc90b0
......@@ -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
......
......@@ -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 --------------
......
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