Commit f3c4792f 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 #33

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 dceb1790
...@@ -40,7 +40,8 @@ import TysWiredIn ( unboxedPairDataCon ) ...@@ -40,7 +40,8 @@ import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy ) import TysPrim ( realWorldStatePrimTy )
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
keysUFM, minusUFM, ufmToList, filterUFM ) keysUFM, minusUFM, ufmToList, filterUFM )
import Type ( isUnLiftedType, coreEqType ) import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import CoreLint ( showPass, endPass ) import CoreLint ( showPass, endPass )
import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs ) import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
...@@ -164,16 +165,25 @@ dmdAnal sigs dmd (Lit lit) ...@@ -164,16 +165,25 @@ dmdAnal sigs dmd (Lit lit)
dmdAnal sigs dmd (Var var) dmdAnal sigs dmd (Var var)
= (dmdTransform sigs var dmd, Var var) = (dmdTransform sigs var dmd, Var var)
dmdAnal sigs dmd (Cast e co)
= (dmd_ty, Cast e' co)
where
(dmd_ty, e') = dmdAnal sigs dmd' e
to_co = snd (coercionKind co)
dmd'
| Just (tc, args) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
| otherwise = dmd
-- This coerce usually arises from a recursive
-- newtype, and we don't want to look inside them
-- for exactly the same reason that we don't look
-- inside recursive products -- we might not reach
-- a fixpoint. So revert to a vanilla Eval demand
dmdAnal sigs dmd (Note n e) dmdAnal sigs dmd (Note n e)
= (dmd_ty, Note n e') = (dmd_ty, Note n e')
where where
(dmd_ty, e') = dmdAnal sigs dmd' e (dmd_ty, e') = dmdAnal sigs dmd e
dmd' = case n of
Coerce _ _ -> evalDmd -- This coerce usually arises from a recursive
other -> dmd -- newtype, and we don't want to look inside them
-- for exactly the same reason that we don't look
-- inside recursive products -- we might not reach
-- a fixpoint. So revert to a vanilla Eval demand
dmdAnal sigs dmd (App fun (Type ty)) dmdAnal sigs dmd (App fun (Type ty))
= (fun_ty, App fun' (Type ty)) = (fun_ty, App fun' (Type ty))
......
...@@ -153,6 +153,10 @@ wwExpr (Note note expr) ...@@ -153,6 +153,10 @@ wwExpr (Note note expr)
= wwExpr expr `thenUs` \ new_expr -> = wwExpr expr `thenUs` \ new_expr ->
returnUs (Note note new_expr) returnUs (Note note new_expr)
wwExpr (Cast expr co)
= wwExpr expr `thenUs` \ new_expr ->
returnUs (Cast new_expr co)
wwExpr (Let bind expr) wwExpr (Let bind expr)
= wwBind bind `thenUs` \ intermediate_bind -> = wwBind bind `thenUs` \ intermediate_bind ->
wwExpr expr `thenUs` \ new_expr -> wwExpr expr `thenUs` \ new_expr ->
......
...@@ -22,6 +22,7 @@ import TysWiredIn ( tupleCon ) ...@@ -22,6 +22,7 @@ import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys, import Type ( Type, isUnLiftedType, mkFunTys,
splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType
) )
import Coercion ( Coercion, mkSymCoercion, splitRecNewTypeCo_maybe )
import BasicTypes ( Boxity(..) ) import BasicTypes ( Boxity(..) )
import Var ( Var, isId ) import Var ( Var, isId )
import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM ) import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
...@@ -223,7 +224,7 @@ mkWWargs :: Type ...@@ -223,7 +224,7 @@ mkWWargs :: Type
Type) -- Type of wrapper body Type) -- Type of wrapper body
mkWWargs fun_ty demands one_shots mkWWargs fun_ty demands one_shots
| Just rep_ty <- splitRecNewType_maybe fun_ty | Just (rep_ty, co) <- splitRecNewTypeCo_maybe fun_ty
-- The newtype case is for when the function has -- The newtype case is for when the function has
-- a recursive newtype after the arrow (rare) -- a recursive newtype after the arrow (rare)
-- We check for arity >= 0 to avoid looping in the case -- We check for arity >= 0 to avoid looping in the case
...@@ -236,8 +237,8 @@ mkWWargs fun_ty demands one_shots ...@@ -236,8 +237,8 @@ mkWWargs fun_ty demands one_shots
-- simply coerces. -- simply coerces.
= mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
returnUs (wrap_args, returnUs (wrap_args,
Note (Coerce fun_ty rep_ty) . wrap_fn_args, \ e -> Cast (wrap_fn_args e) co,
work_fn_args . Note (Coerce rep_ty fun_ty), \ e -> work_fn_args (Cast e (mkSymCoercion co)),
res_ty) res_ty)
| notNull demands | notNull demands
......
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