[project @ 2000-10-24 08:40:09 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 481c6f5..bcb1d9d 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -20,28 +20,22 @@ import StgSyn               -- output
 import CoreUtils       ( exprType )
 import SimplUtils      ( findDefault )
 import CostCentre      ( noCCS )
-import Id              ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId,
-                         externallyVisibleId, setIdUnique, idName, 
-                         idDemandInfo, idArity, setIdType, idFlavour
+import Id              ( Id, mkSysLocal, idType, idStrictness, isExportedId, 
+                         mkVanillaId, idName, idDemandInfo, idArity, setIdType,
+                         idFlavour
                        )
-import Var             ( Var, varType, modifyIdInfo )
-import IdInfo          ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) )
-import UsageSPUtils     ( primOpUsgTys )
-import DataCon         ( DataCon, dataConName, dataConWrapId )
-import Demand          ( Demand, isStrict, wwStrict, wwLazy )
-import Name            ( Name, nameModule, isLocallyDefinedName, setNameUnique )
-import Literal         ( Literal(..) )
+import IdInfo          ( StrictnessInfo(..), IdFlavour(..) )
+import DataCon         ( dataConWrapId )
+import Demand          ( Demand, isStrict, wwLazy )
+import Name            ( setNameUnique )
 import VarEnv
-import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg )
+import PrimOp          ( PrimOp(..), setCCallUnique )
 import Type            ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
-                          UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
+                          UsageAnn(..), tyUsg, applyTy, repType, seqType,
                          splitRepFunTys, mkFunTys
                        )
-import TysPrim         ( intPrimTy )
 import UniqSupply      -- all of it, really
-import Util            ( lengthExceeds )
-import BasicTypes      ( TopLevelFlag(..), isNotTopLevel, Arity )
-import CmdLineOpts     ( opt_D_verbose_stg2stg, opt_UsageSPOn )
+import BasicTypes      ( TopLevelFlag(..), isNotTopLevel )
 import UniqSet         ( emptyUniqSet )
 import Maybes
 import Outputable
@@ -172,12 +166,10 @@ locations.
 
 \begin{code}
 bOGUS_LVs :: StgLiveVars
-bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
-         | otherwise =panic "bOGUS_LVs"
+bOGUS_LVs = emptyUniqSet
 
 bOGUS_FVs :: [Id]
-bOGUS_FVs | opt_D_verbose_stg2stg = [] 
-         | otherwise = panic "bOGUS_FVs"
+bOGUS_FVs = [] 
 \end{code}
 
 \begin{code}
@@ -542,7 +534,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)
@@ -655,11 +648,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')
+          getUniqueUs                  `thenUs` \ uniq ->
+           let ccall' = setCCallUnique ccall uniq in
+          returnUs (StgPrimApp (CCallOp ccall') args' ty')
+          
 
       PrimOpId op 
        -> saturate fn_alias args ty    $ \ args' ty' ->
@@ -788,8 +784,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
@@ -808,8 +804,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 ->
@@ -884,11 +880,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
@@ -907,9 +903,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}