[project @ 2004-08-09 13:19:29 by simonmar]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgCase.lhs

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index af053f6..d313839 100644 (file)
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.66 2003/07/22 16:11:26 simonmar Exp $
+% $Id: CgCase.lhs,v 1.67 2004/08/09 13:19:29 simonmar Exp $
 %
 %********************************************************
 %*                                                     *
@@ -53,6 +53,7 @@ import PrimRep                ( getPrimRepSize, retPrimRepSize, PrimRep(..)
                        )
 import TyCon           ( TyCon, isEnumerationTyCon, tyConPrimRep       )
 import Unique           ( Unique, Uniquable(..), newTagUnique )
+import ForeignCall
 import Util            ( only )
 import List            ( sortBy )
 import Outputable
@@ -145,14 +146,14 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
     bindNewToTemp bndr                 `thenFC` \ tmp_amode ->
     absC (CAssign tmp_amode amode)     `thenC`
     cgPrimAlts NoGC tmp_amode alts alt_type
-\end{code}     
+\end{code}
 
-Special case #3: inline PrimOps.
+Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}
-cgCase (StgOpApp op@(StgPrimOp primop) args _) 
+cgCase (StgOpApp op args _) 
        live_in_whole_case live_in_alts bndr srt alt_type alts
-  | not (primOpOutOfLine primop)
+  | inline_primop
   =    -- Get amodes for the arguments and results
     getArgAmodes args                  `thenFC` \ arg_amodes ->
     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
@@ -175,7 +176,30 @@ cgCase (StgOpApp op@(StgPrimOp primop) args _)
           [(_, res_ids, _, rhs)] = alts
 
       AlgAlt tycon     -- ENUMERATION TYPE RETURN
+        | StgPrimOp primop <- op
        -> ASSERT( isEnumerationTyCon tycon )
+          let
+            do_enum_primop :: PrimOp -> FCode CAddrMode        -- Returns amode for result
+            do_enum_primop TagToEnumOp -- No code!
+               = returnFC (only arg_amodes)
+            
+            do_enum_primop primop
+             = absC (COpStmt [tag_amode] op arg_amodes vol_regs)       `thenC`
+               returnFC tag_amode
+             where                     
+               tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+                       -- Being a bit short of uniques for temporary
+                       -- variables here, we use newTagUnique to
+                       -- generate a new unique from the case binder.
+                       -- The case binder's unique will presumably
+                       -- have the 'c' tag (generated by CoreToStg),
+                       -- so we just change its tag to 'C' (for
+                       -- 'case') to ensure it doesn't clash with
+                       -- anything else.  We can't use the unique
+                       -- from the case binder, becaus e this is used
+                       -- to hold the actual result closure (via the
+                       -- call to bindNewToTemp)
+          in
           do_enum_primop primop                `thenFC` \ tag_amode ->
 
                -- Bind the default binder if necessary
@@ -194,27 +218,15 @@ cgCase (StgOpApp op@(StgPrimOp primop) args _)
 
                -- Do the switch
           absC (mkAlgAltsCSwitch tag_amode tagged_alts)
-       where
-          do_enum_primop :: PrimOp -> FCode CAddrMode  -- Returns amode for result
-          do_enum_primop TagToEnumOp   -- No code!
-             = returnFC (only arg_amodes)
-
-          do_enum_primop primop
-             = absC (COpStmt [tag_amode] op arg_amodes vol_regs)       `thenC`
-               returnFC tag_amode
-             where                     
-               tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
-                       -- Being a bit short of uniques for temporary variables here, 
-                       -- we use newTagUnique to generate a new unique from the case 
-                       -- binder.  The case binder's unique will presumably have 
-                       -- the 'c' tag (generated by CoreToStg), so we just change 
-                       -- its tag to 'C' (for 'case') to ensure it doesn't clash with 
-                       -- anything else.
-                       -- We can't use the unique from the case binder, becaus e
-                       -- this is used to hold the actual result closure
-                       -- (via the call to bindNewToTemp)
 
       other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
+  where
+   inline_primop = case op of
+       StgPrimOp primop  -> not (primOpOutOfLine primop)
+       StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
+                -- unsafe foreign calls are "inline"
+       _otherwise -> False
+
 \end{code}
 
 TODO: Case-of-case of primop can probably be done inline too (but