[project @ 1998-11-26 09:17:22 by sof]

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

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 202b8f7..a8f9756 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -27,11 +27,14 @@ import AbsCSyn
 import Digraph         ( stronglyConnComp, SCC(..) )
 import HeapOffs                ( possiblyEqualHeapOffset )
 import Id              ( fIRST_TAG, ConTag )
-import Literal         ( literalPrimRep, Literal(..) )
+import Literal         ( literalPrimRep, Literal(..), mkMachWord )
 import PrimRep         ( getPrimRepSize, PrimRep(..) )
 import Unique          ( Unique{-instance Eq-} )
 import UniqSupply      ( getUnique, getUniques, splitUniqSupply, UniqSupply )
 import Util            ( assocDefaultUsing, panic )
+import CmdLineOpts      ( opt_ProduceC )
+import Maybes          ( maybeToBool )
+import PrimOp          ( PrimOp(..) )
 
 infixr 9 `thenFlt`
 \end{code}
@@ -109,8 +112,7 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
 
    -- We also need to convert to Literals to keep the CSwitch happy
    adjust tagged_alts
-     = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
-       | (tag, abs_c) <- tagged_alts ]
+     = [ (mkMachWord (fromInt (tag - fIRST_TAG)), abs_c) | (tag, abs_c) <- tagged_alts ]
 \end{code}
 
 %************************************************************************
@@ -122,9 +124,10 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
 \begin{code}
 magicIdPrimRep BaseReg             = PtrRep
 magicIdPrimRep StkOReg             = PtrRep
-magicIdPrimRep (VanillaReg kind _) = kind
+magicIdPrimRep (VanillaReg kind _)  = kind
 magicIdPrimRep (FloatReg _)        = FloatRep
 magicIdPrimRep (DoubleReg _)       = DoubleRep
+magicIdPrimRep (LongReg kind _)            = kind
 magicIdPrimRep TagReg              = IntRep
 magicIdPrimRep RetReg              = RetRep
 magicIdPrimRep SpA                 = PtrRep
@@ -391,7 +394,7 @@ flatAbsC (CRetVector tbl_label stuff deflt)
     do_alt deflt_amode Nothing    = returnFlt (deflt_amode, AbsCNop)
     do_alt deflt_amode (Just alt) = flatAmode alt
 
-    bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
+    bogus_default_label = panic ("flatAbsC: CRetVector: default needed and not available")
 
 
 flatAbsC (CRetUnVector label amode)
@@ -444,6 +447,14 @@ flatAbsC stmt@(CInitHdr a b cc u)
   = flatAmode cc       `thenFlt` \ (new_cc, tops) ->
     returnFlt (CInitHdr a b new_cc u, tops)
 
+flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _ _ _) args liveness_mask vol_regs)
+  | maybeToBool opt_ProduceC
+  = flatAmodes results         `thenFlt` \ (results_here, tops1) ->
+    flatAmodes args            `thenFlt` \ (args_here,    tops2) ->
+    let tdef = CCallTypedef td results args in
+    returnFlt (COpStmt results_here td args_here liveness_mask vol_regs,
+              mkAbsCStmts tdef (mkAbsCStmts tops1 tops2))
+
 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
   = flatAmodes results         `thenFlt` \ (results_here, tops1) ->
     flatAmodes args            `thenFlt` \ (args_here,    tops2) ->