[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 c23eb9d..2f59489 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -12,14 +12,14 @@ module CoreToStg ( coreToStg, coreExprToStg ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils
+import CoreUtils       ( rhsIsStatic, manifestArity, exprType )
 import StgSyn
 
 import Type
 import TyCon           ( isAlgTyCon )
-import Literal
 import Id
-import Var             ( Var, globalIdDetails, varType )
+import Var             ( Var, globalIdDetails, idType )
+import TyCon           ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
 #ifdef ILX
 import MkId            ( unsafeCoerceId )
 #endif
@@ -236,31 +236,31 @@ coreToTopStgRhs
 coreToTopStgRhs scope_fv_info (bndr, rhs)
   = coreToStgExpr rhs          `thenLne` \ (new_rhs, rhs_fvs, _) ->
     freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
-    returnLne (mkTopStgRhs upd rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
+    returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
+    is_static = rhsIsStatic rhs
 
-    upd  | rhsIsNonUpd rhs = SingleEntry
-        | otherwise       = Updatable
-
-mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
+mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
        -> StgRhs
 
-mkTopStgRhs upd rhs_fvs srt binder_info (StgLam _ bndrs body)
-  = StgRhsClosure noCCS binder_info
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
+  = ASSERT( is_static )
+    StgRhsClosure noCCS binder_info
                  (getFVs rhs_fvs)               
                  ReEntrant
                  srt
                  bndrs body
        
-mkTopStgRhs upd rhs_fvs srt binder_info (StgConApp con args)
-  | not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp)
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
+  | is_static   -- StgConApps can be updatable (see isCrossDllConApp)
   = StgRhsCon noCCS con args
 
-mkTopStgRhs upd rhs_fvs srt binder_info rhs
-  = StgRhsClosure noCCS binder_info
+mkTopStgRhs is_static rhs_fvs srt binder_info rhs
+  = ASSERT2( not is_static, ppr rhs )
+    StgRhsClosure noCCS binder_info
                  (getFVs rhs_fvs)               
-                 upd
+                 Updatable
                  srt
                  [] rhs
 \end{code}
@@ -333,7 +333,7 @@ coreToStgExpr (Note other_note expr)
 coreToStgExpr (Case scrut bndr alts)
   = extendVarEnvLne [(bndr, LambdaBound)]      (
         mapAndUnzip3Lne vars_alt alts  `thenLne` \ (alts2, fvs_s, escs_s) ->
-        returnLne ( mkStgAlts (idType bndr) alts2,
+        returnLne ( alts2,
                     unionFVInfos fvs_s,
                     unionVarSets escs_s )
     )                                  `thenLne` \ (alts2, alts_fvs, alts_escs) ->
@@ -367,6 +367,7 @@ coreToStgExpr (Case scrut bndr alts)
                     (getLiveVars alts_lv_info)
                     bndr'
                     (mkSRT alts_lv_info)
+                    (mkStgAltType (idType bndr)) 
                     alts2,
       scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
       alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
@@ -406,28 +407,15 @@ coreToStgExpr (Let bind body)
 \end{code}
 
 \begin{code}
-mkStgAlts scrut_ty orig_alts
- | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
- | otherwise    = StgAlgAlts  maybe_tycon             alg_alts  deflt
-  where
-    is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
-
-    prim_alts    = [(lit, rhs)                    | (LitAlt lit, _, _, rhs)        <- other_alts]
-    alg_alts    = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
-
-    (other_alts, deflt) 
-       = case orig_alts of     -- DEFAULT is always first if it's there at all
-           (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
-           other                             -> (orig_alts,  StgNoDefault)
-
-    maybe_tycon = case alg_alts of 
-                       -- Get the tycon from the data con
-                       (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
-
-                       -- Otherwise just do your best
-                       [] -> case splitTyConApp_maybe (repType scrut_ty) of
-                               Just (tc,_) | isAlgTyCon tc -> Just tc
-                               _other                      -> Nothing
+mkStgAltType scrut_ty
+  = case splitTyConApp_maybe (repType scrut_ty) of
+       Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
+                   | isPrimTyCon tc         -> PrimAlt tc
+                   | isHiBootTyCon tc       -> PolyAlt -- Algebraic, but no constructors visible
+                   | isAlgTyCon tc          -> AlgAlt tc
+                   | isFunTyCon tc          -> PolyAlt
+                   | otherwise              -> pprPanic "mkStgAlts" (ppr tc)
+       Nothing                              -> PolyAlt
 \end{code}
 
 
@@ -458,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
@@ -873,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)  ->
@@ -889,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)  ->
@@ -897,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)  ->