[project @ 2000-10-12 13:11:45 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 e7a563e..11a26f3 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -28,10 +28,11 @@ import Unique               ( Unique{-instance Eq-} )
 import UniqSupply      ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, 
                          UniqSupply )
 import CmdLineOpts      ( opt_OutputLanguage, opt_EmitCExternDecls )
-import Maybes          ( maybeToBool )
-import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )
+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}
 
 %************************************************************************
@@ -156,7 +167,6 @@ getAmodeRep (CLbl _ kind)               = kind
 getAmodeRep (CCharLike _)                  = PtrRep
 getAmodeRep (CIntLike _)                   = PtrRep
 getAmodeRep (CLit lit)                     = literalPrimRep lit
-getAmodeRep (CLitLit _ kind)               = kind
 getAmodeRep (CMacroExpr kind _ _)          = kind
 getAmodeRep (CJoinPoint _)                 = panic "getAmodeRep:CJoinPoint"
 \end{code}
@@ -329,16 +339,16 @@ flatAbsC (CSwitch discrim alts deflt)
       = flatAbsC absC  `thenFlt` \ (alt_heres, alt_tops) ->
        returnFlt ( (tag, alt_heres), alt_tops )
 
-flatAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs)
+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
-    (isCandidate, isDyn) =
-      case ccall of 
-        CCall (DynamicTarget _) _ _ _      -> (True, True)
-       CCall (StaticTarget _) is_asm _ _  -> (opt_EmitCExternDecls && not is_asm, False)
+    isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
+    is_dynamic  = isDynamicTarget target
 
-    tdef = CCallTypedef isDyn ccall results args
+    tdef = CCallTypedef is_dynamic ccall results args
 
 flatAbsC stmt@(CSimultaneous abs_c)
   = flatAbsC abs_c             `thenFlt` \ (stmts_here, tops) ->
@@ -431,7 +441,7 @@ sameAmode :: CAddrMode -> CAddrMode -> Bool
 -- At the moment we put in just enough to catch the cases we want:
 --     the second (destination) argument is always a CVal.
 sameAmode (CReg r1)                 (CReg r2)               = r1 == r2
-sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _)           = r1 _EQ_ r2
+sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _)           = r1 ==# r2
 sameAmode other1                    other2                  = False
 
 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
@@ -510,7 +520,7 @@ other1                `conflictsWith` other2                = False
 
 regConflictsWithRR :: MagicId -> RegRelative -> Bool
 
-regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _)  = True
+regConflictsWithRR (VanillaReg k _ILIT(1)) (NodeRel _) = True
 
 regConflictsWithRR Sp  (SpRel _)       = True
 regConflictsWithRR Hp  (HpRel _)       = True
@@ -523,14 +533,14 @@ rrConflictsWithRR :: Int -> Int                   -- Sizes of two things
 rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2
   where
     rr (SpRel o1)    (SpRel o2)
-       | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
-       | s1 _EQ_ ILIT(1)  && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
-       | otherwise          = (o1 _ADD_ s1) _GE_ o2  &&
-                              (o2 _ADD_ s2) _GE_ o1
+       | s1 ==# _ILIT(0) || s2 ==# _ILIT(0) = False -- No conflict if either is size zero
+       | s1 ==# _ILIT(1)  && s2 ==# _ILIT(1) = o1 ==# o2
+       | otherwise          = (o1 +# s1) >=# o2  &&
+                              (o2 +# s2) >=# o1
 
     rr (NodeRel o1)     (NodeRel o2)
-       | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
-       | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
+       | s1 ==# _ILIT(0) || s2 ==# _ILIT(0) = False -- No conflict if either is size zero
+       | s1 ==# _ILIT(1) && s2 ==# _ILIT(1) = o1 ==# o2
        | otherwise          = True             -- Give up
 
     rr (HpRel _)        (HpRel _)    = True    -- Give up (ToDo)