projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2004-10-18 18:24:59 by igloo]
[ghc-hetmet.git]
/
ghc
/
compiler
/
stgSyn
/
CoreToStg.lhs
diff --git
a/ghc/compiler/stgSyn/CoreToStg.lhs
b/ghc/compiler/stgSyn/CoreToStg.lhs
index
603d2dd
..
61e67df
100644
(file)
--- a/
ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/
ghc/compiler/stgSyn/CoreToStg.lhs
@@
-18,8
+18,8
@@
import StgSyn
import Type
import TyCon ( isAlgTyCon )
import Id
import Type
import TyCon ( isAlgTyCon )
import Id
-import Var ( Var, globalIdDetails, varType )
-import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon )
+import Var ( Var, globalIdDetails, idType )
+import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
#ifdef ILX
import MkId ( unsafeCoerceId )
#endif
#ifdef ILX
import MkId ( unsafeCoerceId )
#endif
@@
-257,7
+257,7
@@
mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
= StgRhsCon noCCS con args
mkTopStgRhs is_static rhs_fvs srt binder_info rhs
= StgRhsCon noCCS con args
mkTopStgRhs is_static rhs_fvs srt binder_info rhs
- = ASSERT( not is_static )
+ = ASSERT2( not is_static, ppr rhs )
StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
Updatable
@@
-330,7
+330,8
@@
coreToStgExpr (Note other_note expr)
-- Cases require a little more real work.
-- Cases require a little more real work.
-coreToStgExpr (Case scrut bndr alts)
+-- gaw 2004
+coreToStgExpr (Case scrut bndr _ alts)
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
returnLne ( alts2,
= extendVarEnvLne [(bndr, LambdaBound)] (
mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
returnLne ( alts2,
@@
-411,7
+412,8
@@
mkStgAltType scrut_ty
= case splitTyConApp_maybe (repType scrut_ty) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isPrimTyCon tc -> PrimAlt tc
= case splitTyConApp_maybe (repType scrut_ty) of
Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
| isPrimTyCon tc -> PrimAlt tc
- | isAlgTyCon tc -> AlgAlt tc
+ | isHiBootTyCon tc -> PolyAlt -- Algebraic, but no constructors visible
+ | isAlgTyCon tc -> AlgAlt tc
| isFunTyCon tc -> PolyAlt
| otherwise -> pprPanic "mkStgAlts" (ppr tc)
Nothing -> PolyAlt
| isFunTyCon tc -> PolyAlt
| otherwise -> pprPanic "mkStgAlts" (ppr tc)
Nothing -> PolyAlt
@@
-445,7
+447,7
@@
coreToStgApp maybe_thunk_body f args
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
if opt_RuntimeTypes then
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
if opt_RuntimeTypes then
- fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
+ fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
else fvs
-- Mostly, the arity info of a function is in the fn's IdInfo
else fvs
-- Mostly, the arity info of a function is in the fn's IdInfo
@@
-860,15
+862,7
@@
thenLne :: LneM a -> (a -> LneM b) -> LneM b
thenLne m k env lvs_cont
= k (m env lvs_cont) env lvs_cont
thenLne m k env lvs_cont
= k (m env lvs_cont) env lvs_cont
-mapLne :: (a -> LneM b) -> [a] -> LneM [b]
-mapLne f [] = returnLne []
-mapLne f (x:xs)
- = f x `thenLne` \ r ->
- mapLne f xs `thenLne` \ rs ->
- returnLne (r:rs)
-
mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
-
mapAndUnzipLne f [] = returnLne ([],[])
mapAndUnzipLne f (x:xs)
= f x `thenLne` \ (r1, r2) ->
mapAndUnzipLne f [] = returnLne ([],[])
mapAndUnzipLne f (x:xs)
= f x `thenLne` \ (r1, r2) ->
@@
-876,7
+870,6
@@
mapAndUnzipLne f (x:xs)
returnLne (r1:rs1, r2:rs2)
mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
returnLne (r1:rs1, r2:rs2)
mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
-
mapAndUnzip3Lne f [] = returnLne ([],[],[])
mapAndUnzip3Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3) ->
mapAndUnzip3Lne f [] = returnLne ([],[],[])
mapAndUnzip3Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3) ->
@@
-884,7
+877,6
@@
mapAndUnzip3Lne f (x:xs)
returnLne (r1:rs1, r2:rs2, r3:rs3)
mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
returnLne (r1:rs1, r2:rs2, r3:rs3)
mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
-
mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
mapAndUnzip4Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3, r4) ->
mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
mapAndUnzip4Lne f (x:xs)
= f x `thenLne` \ (r1, r2, r3, r4) ->
@@
-1030,12
+1022,12
@@
lookupFVInfo fvs id
Just (_,_,info) -> info
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
Just (_,_,info) -> info
allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
-allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
+allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
-- Non-top-level things only, both type variables and ids
-- (type variables only if opt_RuntimeTypes)
getFVs :: FreeVarsInfo -> [Var]
-- Non-top-level things only, both type variables and ids
-- (type variables only if opt_RuntimeTypes)
getFVs :: FreeVarsInfo -> [Var]
-getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
+getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
not (topLevelBound how_bound) ]
getFVSet :: FreeVarsInfo -> VarSet
not (topLevelBound how_bound) ]
getFVSet :: FreeVarsInfo -> VarSet