[project @ 2000-12-06 11:20:14 by sewardj]

[ghc-hetmet.git] / ghc / compiler / simplStg / LambdaLift.lhs

diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs
index 5694475..96de466 100644 (file)
--- a/ghc/compiler/simplStg/LambdaLift.lhs
+++ b/ghc/compiler/simplStg/LambdaLift.lhs
@@ -10,16 +10,20 @@ module LambdaLift ( liftProgram ) where
 
 import StgSyn
 
+import CmdLineOpts     ( opt_EnsureSplittableC )
 import Bag             ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList )
 import Id              ( mkVanillaId, idType, setIdArityInfo, Id )
 import VarSet
 import VarEnv
 import IdInfo          ( exactArity )
 import Module          ( Module )
-import Name             ( mkTopName )
+import Name             ( Name, mkGlobalName, mkLocalName ) 
+import OccName         ( mkVarOcc )
 import Type            ( splitForAllTys, mkForAllTys, mkFunTys, Type )
+import Unique          ( Unique )
 import UniqSupply      ( uniqFromSupply, splitUniqSupply, UniqSupply )
 import Util            ( zipEqual )
+import SrcLoc          ( noSrcLoc )
 import Panic           ( panic, assertPanic )
 \end{code}
 
@@ -161,15 +165,15 @@ liftExpr (StgCase scrut lv1 lv2 bndr srt alts)
     lift_alts alts     `thenLM` \ (alts', alts_info) ->
     returnLM (StgCase scrut' lv1 lv2 bndr srt alts', scrut_info `unionLiftInfo` alts_info)
   where
-    lift_alts (StgAlgAlts ty alg_alts deflt)
+    lift_alts (StgAlgAlts tycon alg_alts deflt)
        = mapAndUnzipLM lift_alg_alt alg_alts   `thenLM` \ (alg_alts', alt_infos) ->
          lift_deflt deflt                      `thenLM` \ (deflt', deflt_info) ->
-         returnLM (StgAlgAlts ty alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
+         returnLM (StgAlgAlts tycon alg_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
 
-    lift_alts (StgPrimAlts ty prim_alts deflt)
+    lift_alts (StgPrimAlts tycon prim_alts deflt)
        = mapAndUnzipLM lift_prim_alt prim_alts `thenLM` \ (prim_alts', alt_infos) ->
          lift_deflt deflt                      `thenLM` \ (deflt', deflt_info) ->
-         returnLM (StgPrimAlts ty prim_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
+         returnLM (StgPrimAlts tycon prim_alts' deflt', foldr unionLiftInfo deflt_info alt_infos)
 
     lift_alg_alt (con, args, use_mask, rhs)
        = liftExpr rhs          `thenLM` \ (rhs', rhs_info) ->
@@ -449,6 +453,23 @@ newSupercombinator ty arity mod ci us idenv
   where
     uniq = uniqFromSupply us
 
+
+mkTopName :: Unique -> Module -> FAST_STRING -> Name
+       -- Make a top-level name; make it Global if top-level
+       -- things should be externally visible; Local otherwise
+       -- This chap is only used *after* the tidyCore phase
+       -- Notably, it is used during STG lambda lifting
+       --
+       -- We have to make sure that the name is globally unique
+       -- and we don't have tidyCore to help us. So we append
+       -- the unique.  Hack!  Hack!
+       -- (Used only by the STG lambda lifter.)
+mkTopName uniq mod fs
+  | opt_EnsureSplittableC = mkGlobalName uniq mod occ noSrcLoc
+  | otherwise            = mkLocalName uniq occ noSrcLoc
+  where
+    occ = mkVarOcc (_PK_ ((_UNPK_ fs) ++ show uniq))
+
 lookUp :: Id -> LiftM (Id,[Id])
 lookUp v mod ci us idenv
   = case (lookupVarEnv idenv v) of