[project @ 2004-01-12 12:13:26 by simonpj]

[ghc-hetmet.git] / ghc / compiler / stgSyn / CoreToStg.lhs

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 358d29f..2f59489 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -17,10 +17,9 @@ import StgSyn
 
 import Type
 import TyCon           ( isAlgTyCon )
-import Literal
 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
@@ -258,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
-  = ASSERT( not is_static )
+  = ASSERT2( not is_static, ppr rhs )
     StgRhsClosure noCCS binder_info
                  (getFVs rhs_fvs)               
                  Updatable
@@ -412,7 +411,8 @@ mkStgAltType scrut_ty
   = 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
@@ -446,7 +446,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
-             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
@@ -861,15 +861,7 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b
 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 f [] = returnLne ([],[])
 mapAndUnzipLne f (x:xs)
   = f x                        `thenLne` \ (r1,  r2)  ->
@@ -877,7 +869,6 @@ mapAndUnzipLne f (x:xs)
     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)  ->
@@ -885,7 +876,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])
-
 mapAndUnzip4Lne f []   = returnLne ([],[],[],[])
 mapAndUnzip4Lne f (x:xs)
   = f x                         `thenLne` \ (r1,  r2,  r3, r4)  ->