[project @ 2000-09-06 10:23:52 by simonmar]

[ghc-hetmet.git] / ghc / compiler / absCSyn / AbsCUtils.lhs

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 072be07..f380da9 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -22,16 +22,17 @@ module AbsCUtils (
 import AbsCSyn
 import Digraph         ( stronglyConnComp, SCC(..) )
 import DataCon         ( fIRST_TAG, ConTag )
-import Const           ( literalPrimRep, mkMachWord )
+import Literal         ( literalPrimRep, mkMachWord )
 import PrimRep         ( getPrimRepSize, PrimRep(..) )
 import Unique          ( Unique{-instance Eq-} )
 import UniqSupply      ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, 
                          UniqSupply )
-import CmdLineOpts      ( opt_ProduceC )
-import Maybes          ( maybeToBool )
-import PrimOp          ( PrimOp(..) )
+import CmdLineOpts      ( opt_OutputLanguage, opt_EmitCExternDecls )
+import PrimOp          ( PrimOp(..), CCall(..), isDynamicTarget )
 import Panic           ( panic )
 
+import Maybe           ( isJust )
+
 infixr 9 `thenFlt`
 \end{code}
 
@@ -101,8 +102,16 @@ mkAbsCStmtList' other r = other : r
 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
 
 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
- = CSwitch scrutinee (adjust tagged_alts) deflt_absc
+ | isJust (nonemptyAbsC deflt_absc) 
+       = CSwitch scrutinee (adjust tagged_alts) deflt_absc
+ | otherwise 
+       = CSwitch scrutinee (adjust rest) first_alt
  where
+   -- it's ok to convert one of the alts into a default if we don't already have
+   -- one, because this is an algebraic case and we're guaranteed that the tag 
+   -- will match one of the branches.
+   ((tag,first_alt):rest) = tagged_alts
+
    -- Adjust the tags in the switch to start at zero.
    -- This is the convention used by primitive ops which return algebraic
    -- data types.  Why?         Because for two-constructor types, zero is faster
@@ -133,6 +142,8 @@ magicIdPrimRep Hp               = PtrRep
 magicIdPrimRep HpLim               = PtrRep
 magicIdPrimRep CurCostCentre       = CostCentreRep
 magicIdPrimRep VoidReg             = VoidRep
+magicIdPrimRep CurrentTSO          = ThreadIdRep
+magicIdPrimRep CurrentNursery      = PtrRep
 \end{code}
 
 %************************************************************************
@@ -152,17 +163,12 @@ getAmodeRep (CVal _ kind)             = kind
 getAmodeRep (CAddr _)                      = PtrRep
 getAmodeRep (CReg magic_id)                = magicIdPrimRep magic_id
 getAmodeRep (CTemp uniq kind)              = kind
-getAmodeRep (CLbl label kind)              = kind
+getAmodeRep (CLbl _ kind)                  = kind
 getAmodeRep (CCharLike _)                  = PtrRep
 getAmodeRep (CIntLike _)                   = PtrRep
-getAmodeRep (CString _)                            = PtrRep
 getAmodeRep (CLit lit)                     = literalPrimRep lit
-getAmodeRep (CLitLit _ kind)               = kind
-getAmodeRep (CTableEntry _ _ kind)         = kind
 getAmodeRep (CMacroExpr kind _ _)          = kind
-#ifdef DEBUG
 getAmodeRep (CJoinPoint _)                 = panic "getAmodeRep:CJoinPoint"
-#endif
 \end{code}
 
 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
@@ -312,9 +318,9 @@ flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
        CClosureInfoAndCode cl_info slow_heres fast_heres descr]
     )
 
-flatAbsC (CCodeBlock label abs_C)
+flatAbsC (CCodeBlock lbl abs_C)
   = flatAbsC abs_C         `thenFlt` \ (absC_heres, absC_tops) ->
-    returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
+    returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
 
 flatAbsC (CRetDirect uniq slow_code srt liveness)
   = flatAbsC slow_code         `thenFlt` \ (heres, tops) ->
@@ -333,11 +339,16 @@ flatAbsC (CSwitch discrim alts deflt)
       = flatAbsC absC  `thenFlt` \ (alt_heres, alt_tops) ->
        returnFlt ( (tag, alt_heres), alt_tops )
 
-flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _) args vol_regs)
-  | maybeToBool opt_ProduceC
+flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
+  | isCandidate && opt_OutputLanguage == Just "C"      -- Urgh
   = returnFlt (stmt, tdef)
+  | otherwise
+  = returnFlt (stmt, AbsCNop)
   where
-    tdef = CCallTypedef td results args
+    isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
+    is_dynamic  = isDynamicTarget target
+
+    tdef = CCallTypedef is_dynamic ccall results args
 
 flatAbsC stmt@(CSimultaneous abs_c)
   = flatAbsC abs_c             `thenFlt` \ (stmts_here, tops) ->
@@ -348,9 +359,14 @@ flatAbsC stmt@(CCheck macro amodes code)
   = flatAbsC code              `thenFlt` \ (code_here, code_tops) ->
     returnFlt (CCheck macro amodes code_here, code_tops)
 
+-- the TICKY_CTR macro always needs to be hoisted out to the top level. 
+-- This is a HACK.
+flatAbsC stmt@(CCallProfCtrMacro str amodes)
+  | str == SLIT("TICK_CTR")    = returnFlt (AbsCNop, stmt)
+  | otherwise                  = returnFlt (stmt, AbsCNop)
+
 -- Some statements need no flattening at all:
 flatAbsC stmt@(CMacroStmt macro amodes)        = returnFlt (stmt, AbsCNop)
-flatAbsC stmt@(CCallProfCtrMacro str amodes)   = returnFlt (stmt, AbsCNop)
 flatAbsC stmt@(CCallProfCCMacro str amodes)    = returnFlt (stmt, AbsCNop)
 flatAbsC stmt@(CAssign dest source)            = returnFlt (stmt, AbsCNop)
 flatAbsC stmt@(CJump target)                   = returnFlt (stmt, AbsCNop)
@@ -369,6 +385,7 @@ flatAbsC stmt@(CCostCentreDecl _ _)                 = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CCostCentreStackDecl _)         = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CSplitMarker)                   = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CRetVector _ _ _ _)              = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CModuleInitBlock _ _)            = returnFlt (AbsCNop, stmt)
 \end{code}
 
 \begin{code}