[project @ 2000-06-30 13:11:07 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 6e2d065..44cff7e 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -17,6 +17,7 @@ module CoreToStg ( topCoreBindsToStg ) where
 import CoreSyn         -- input
 import StgSyn          -- output
 
+import PprCore         ( {- instance Outputable Bind/Expr -} )
 import CoreUtils       ( exprType )
 import SimplUtils      ( findDefault )
 import CostCentre      ( noCCS )
@@ -27,13 +28,12 @@ import Id           ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVan
 import Var             ( Var, varType, modifyIdInfo )
 import IdInfo          ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) )
 import UsageSPUtils     ( primOpUsgTys )
-import DataCon         ( DataCon, dataConName, isDynDataCon, dataConWrapId )
+import DataCon         ( DataCon, dataConName, dataConWrapId )
 import Demand          ( Demand, isStrict, wwStrict, wwLazy )
 import Name            ( Name, nameModule, isLocallyDefinedName, setNameUnique )
-import Module          ( isDynamicModule )
 import Literal         ( Literal(..) )
 import VarEnv
-import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg )
+import PrimOp          ( PrimOp(..), setCCallUnique, primOpUsg )
 import Type            ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
                           UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
                          splitRepFunTys, mkFunTys
@@ -302,12 +302,9 @@ exprToRhs dem _ (StgLam _ bndrs body)
   then be run at load time to fix up static closures.
 -}
 exprToRhs dem toplev (StgConApp con args)
-  | isNotTopLevel toplev ||
-    (not is_dynamic  &&
-     all (not . isLitLitArg) args)
+  | isNotTopLevel toplev || not (isDllConApp con args)
+       -- isDllConApp checks for LitLit args too
   = StgRhsCon noCCS con args
- where
-  is_dynamic = isDynDataCon con || any (isDynArg) args
 
 exprToRhs dem _ expr
   = upd `seq` 
@@ -546,7 +543,8 @@ coreExprToStgFloat env (Case scrut bndr alts)
   = coreExprToStgFloat env scrut               `thenUs` \ (binds, scrut') ->
     newLocalId NotTopLevel env bndr            `thenUs` \ (env', bndr') ->
     alts_to_stg env' (findDefault alts)                `thenUs` \ alts' ->
-    returnUs (binds, mkStgCase scrut' bndr' alts')
+    mkStgCase scrut' bndr' alts'               `thenUs` \ expr' ->
+    returnUs (binds, expr')
   where
     scrut_ty  = idType bndr
     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
@@ -659,11 +657,14 @@ mkStgApp env fn args ty
        -> saturate fn_alias args ty    $ \ args' ty' ->
           returnUs (StgConApp dc args')
 
-      PrimOpId (CCallOp (CCall (DynamicTarget _) a b c))
+      PrimOpId (CCallOp ccall)
                -- Sigh...make a guaranteed unique name for a dynamic ccall
+               -- Done here, not earlier, because it's a code-gen thing
        -> saturate fn_alias args ty    $ \ args' ty' ->
-          getUniqueUs                  `thenUs` \ u ->
-           returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty')
+           returnUs (StgPrimApp (CCallOp ccall') args' ty')
+       where
+          ccall' = setCCallUnique ccall (idUnique fn)  
+                       -- The particular unique doesn't matter
 
       PrimOpId op 
        -> saturate fn_alias args ty    $ \ args' ty' ->
@@ -792,8 +793,8 @@ mk_stg_let bndr rhs dem floats body
 #endif
   | isUnLiftedType bndr_rep_ty                 -- Use a case/PrimAlts
   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
-    mkStgBinds floats $
-    mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
+    mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))      `thenUs` \ expr' ->
+    mkStgBinds floats expr'
 
   | is_whnf
   = if is_strict then
@@ -812,8 +813,8 @@ mk_stg_let bndr rhs dem floats body
   | otherwise  -- Not WHNF
   = if is_strict then
        -- Strict let with non-WHNF rhs
-       mkStgBinds floats $
-       mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
+       mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))    `thenUs` \ expr' ->
+       mkStgBinds floats expr'
     else
        -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
        mkStgBinds floats rhs           `thenUs` \ new_rhs ->
@@ -888,11 +889,11 @@ way to enforce ordering  --SDM.
 -- Discard alernatives in case (par# ..) of 
 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
          (StgPrimAlts ty _ deflt@(StgBindDefault _))
-  = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)
+  = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt))
 
 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr 
          (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
-  = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs))
+  = mkStgCase scrut_expr new_bndr new_alts
   where
     new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
             | otherwise               = StgAlgAlts  scrut_ty [] deflt
@@ -911,9 +912,15 @@ mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
                   StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
 
 mkStgCase scrut bndr alts
-  = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
-       -- We should never find 
-       --      case (\x->e) of { ... }
-       -- The simplifier eliminates such things
-    StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
+  = deStgLam scrut     `thenUs` \ scrut' ->
+       -- It is (just) possible to get a lambda as a srutinee here
+       -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
+       -- gives:       case ...Bool == Int->Int... of
+       --                 True -> case coerce Bool (\x -> + 1 x) of
+       --                              True -> ...
+       --                              False -> ...
+       --                 False -> ...
+       -- The True branch of the outer case will never happen, of course.
+
+    returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
 \end{code}