Commit dceb1790 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 #32

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 76ca9b9e
...@@ -16,6 +16,7 @@ import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault ) ...@@ -16,6 +16,7 @@ import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
import StgSyn import StgSyn
import Type import Type
import Coercion ( mkUnsafeCoercion )
import TyCon ( isAlgTyCon ) import TyCon ( isAlgTyCon )
import Id import Id
import Var ( Var, globalIdDetails, idType ) import Var ( Var, globalIdDetails, idType )
...@@ -185,7 +186,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs) ...@@ -185,7 +186,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
bind = StgNonRec id stg_rhs bind = StgNonRec id stg_rhs
in in
ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
ASSERT2(consistentCafInfo id bind, ppr id) ASSERT2(consistentCafInfo id bind, ppr id)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind) (env', fvs' `unionFVInfo` body_fvs, bind)
...@@ -321,17 +322,21 @@ coreToStgExpr (Note (SCC cc) expr) ...@@ -321,17 +322,21 @@ coreToStgExpr (Note (SCC cc) expr)
returnLne (StgSCC cc expr2, fvs, escs) ) returnLne (StgSCC cc expr2, fvs, escs) )
#ifdef ILX #ifdef ILX
-- For ILX, convert (__coerce__ to_ty from_ty e) -- For ILX, convert (__coerce__ to_ty from_ty e)
-- into (coerce to_ty from_ty e) -- into (coerce to_ty from_ty e)
-- where coerce is real function -- where coerce is real function
coreToStgExpr (Note (Coerce to_ty from_ty) expr) coreToStgExpr (Cast expr co)
= coreToStgExpr (mkApps (Var unsafeCoerceId) = let (from_ty, ty_ty) = coercionKind co in
[Type from_ty, Type to_ty, expr]) coreToStgExpr (mkApps (Var unsafeCoerceId)
[Type from_ty, Type to_ty, expr])
#endif #endif
coreToStgExpr (Note other_note expr) coreToStgExpr (Note other_note expr)
= coreToStgExpr expr = coreToStgExpr expr
coreToStgExpr (Cast expr co)
= coreToStgExpr expr
-- Cases require a little more real work. -- Cases require a little more real work.
coreToStgExpr (Case scrut bndr _ alts) coreToStgExpr (Case scrut bndr _ alts)
...@@ -1083,6 +1088,7 @@ myCollectBinders expr ...@@ -1083,6 +1088,7 @@ myCollectBinders expr
where where
go bs (Lam b e) = go (b:bs) e go bs (Lam b e) = go (b:bs) e
go bs e@(Note (SCC _) _) = (reverse bs, e) go bs e@(Note (SCC _) _) = (reverse bs, e)
go bs (Cast e co) = go bs e
go bs (Note _ e) = go bs e go bs (Note _ e) = go bs e
go bs e = (reverse bs, e) go bs e = (reverse bs, e)
...@@ -1095,6 +1101,7 @@ myCollectArgs expr ...@@ -1095,6 +1101,7 @@ myCollectArgs expr
go (Var v) as = (v, as) go (Var v) as = (v, as)
go (App f a) as = go f (a:as) go (App f a) as = go f (a:as)
go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
go (Cast e co) as = go e as
go (Note n e) as = go e as go (Note n e) as = go e as
go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code} \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