[project @ 2004-11-26 16:19:45 by simonmar]

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

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 02258a9..9397af6 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -19,7 +19,7 @@ import Type
 import TyCon           ( isAlgTyCon )
 import Id
 import Var             ( Var, globalIdDetails, idType )
-import TyCon           ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon )
+import TyCon           ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon )
 #ifdef ILX
 import MkId            ( unsafeCoerceId )
 #endif
@@ -142,7 +142,7 @@ for x, solely to put in the SRTs lower down.
 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
 coreToStg dflags pgm
   = return pgm'
-  where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
+  where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm
 
 coreExprToStg :: CoreExpr -> StgExpr
 coreExprToStg expr 
@@ -150,33 +150,35 @@ coreExprToStg expr
 
 
 coreTopBindsToStg
-    :: IdEnv HowBound          -- environment for the bindings
+    :: DynFlags
+    -> IdEnv HowBound          -- environment for the bindings
     -> [CoreBind]
     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 
-coreTopBindsToStg env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg env (b:bs)
+coreTopBindsToStg dflags env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg dflags env (b:bs)
   = (env2, fvs2, b':bs')
   where
        -- env accumulates down the list of binds, fvs accumulates upwards
-       (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
-       (env2, fvs1, bs') = coreTopBindsToStg env1 bs
+       (env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b
+       (env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs
 
 
 coreTopBindToStg
-       :: IdEnv HowBound
+       :: DynFlags
+       -> IdEnv HowBound
        -> FreeVarsInfo         -- Info about the body
        -> CoreBind
        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 
-coreTopBindToStg env body_fvs (NonRec id rhs)
+coreTopBindToStg dflags env body_fvs (NonRec id rhs)
   = let 
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet (manifestArity rhs)
 
         (stg_rhs, fvs') = 
            initLne env (
-              coreToTopStgRhs body_fvs (id,rhs)        `thenLne` \ (stg_rhs, fvs') ->
+              coreToTopStgRhs dflags body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
              returnLne (stg_rhs, fvs')
            )
        
@@ -187,7 +189,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
-coreTopBindToStg env body_fvs (Rec pairs)
+coreTopBindToStg dflags env body_fvs (Rec pairs)
   = let 
        (binders, rhss) = unzip pairs
 
@@ -197,7 +199,7 @@ coreTopBindToStg env body_fvs (Rec pairs)
 
         (stg_rhss, fvs')
          = initLne env' (
-              mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
+              mapAndUnzipLne (coreToTopStgRhs dflags body_fvs) pairs
                                                `thenLne` \ (stg_rhss, fvss') ->
               let fvs' = unionFVInfos fvss' in
               returnLne (stg_rhss, fvs')
@@ -229,17 +231,18 @@ consistentCafInfo id bind
 
 \begin{code}
 coreToTopStgRhs
-       :: FreeVarsInfo         -- Free var info for the scope of the binding
+       :: DynFlags
+       -> FreeVarsInfo         -- Free var info for the scope of the binding
        -> (Id,CoreExpr)
        -> LneM (StgRhs, FreeVarsInfo)
 
-coreToTopStgRhs scope_fv_info (bndr, rhs)
+coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
   = coreToStgExpr rhs          `thenLne` \ (new_rhs, rhs_fvs, _) ->
     freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
     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
+    is_static = rhsIsStatic dflags rhs
 
 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
        -> StgRhs
@@ -330,7 +333,8 @@ coreToStgExpr (Note other_note expr)
 
 -- 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,
@@ -411,7 +415,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
@@ -1020,12 +1025,12 @@ lookupFVInfo fvs id
                        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]        
-getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, 
+getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, 
                    not (topLevelBound how_bound) ]
 
 getFVSet :: FreeVarsInfo -> VarSet