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 )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
keysUFM, minusUFM, ufmToList, filterUFM )
import Type ( isUnLiftedType, coreEqType )
import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import CoreLint ( showPass, endPass )
import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
......@@ -164,16 +165,25 @@ dmdAnal sigs dmd (Lit lit)
dmdAnal sigs 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)
= (dmd_ty, Note n e')
where
(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
(dmd_ty, e') = dmdAnal sigs dmd e
dmdAnal sigs dmd (App fun (Type ty))
= (fun_ty, App fun' (Type ty))
......
......@@ -153,6 +153,10 @@ wwExpr (Note note expr)
= wwExpr expr `thenUs` \ 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)
= wwBind bind `thenUs` \ intermediate_bind ->
wwExpr expr `thenUs` \ new_expr ->
......
......@@ -22,6 +22,7 @@ import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType
)
import Coercion ( Coercion, mkSymCoercion, splitRecNewTypeCo_maybe )
import BasicTypes ( Boxity(..) )
import Var ( Var, isId )
import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
......@@ -223,7 +224,7 @@ mkWWargs :: Type
Type) -- Type of wrapper body
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
-- a recursive newtype after the arrow (rare)
-- We check for arity >= 0 to avoid looping in the case
......@@ -236,8 +237,8 @@ mkWWargs fun_ty demands one_shots
-- simply coerces.
= mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
returnUs (wrap_args,
Note (Coerce fun_ty rep_ty) . wrap_fn_args,
work_fn_args . Note (Coerce rep_ty fun_ty),
\ e -> Cast (wrap_fn_args e) co,
\ e -> work_fn_args (Cast e (mkSymCoercion co)),
res_ty)
| 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