[project @ 2004-08-13 10:45:16 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 ac75ca1..fef7bf5 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -12,7 +12,8 @@ module AbsCUtils (
        getAmodeRep,
        mixedTypeLocn, mixedPtrLocn,
        flattenAbsC,
-       mkAbsCStmtList
+       mkAbsCStmtList,
+       shimFCallArg
        -- printing/forcing stuff comes from PprAbsC
     ) where
 
@@ -20,9 +21,13 @@ module AbsCUtils (
 #include "../includes/config.h"
 
 import AbsCSyn
+import Type            ( tyConAppTyCon, repType )
+import TysPrim         ( foreignObjPrimTyCon, arrayPrimTyCon, 
+                         byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+                         mutableArrayPrimTyCon )
 import CLabel          ( mkMAP_FROZEN_infoLabel )
 import Digraph         ( stronglyConnComp, SCC(..) )
-import DataCon         ( fIRST_TAG, ConTag )
+import DataCon         ( fIRST_TAG, dataConTag )
 import Literal         ( literalPrimRep, mkMachWord, mkMachInt )
 import PrimRep         ( getPrimRepSize, PrimRep(..) )
 import PrimOp          ( PrimOp(..) )
@@ -31,17 +36,15 @@ import Unique               ( Unique{-instance Eq-} )
 import UniqSupply      ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, 
                          UniqSupply )
 import CmdLineOpts      ( opt_EmitCExternDecls, opt_Unregisterised )
-import ForeignCall     ( ForeignCall(..), CCallSpec(..),
-                         isDynamicTarget, isCasmTarget )
-import StgSyn          ( StgOp(..) )
+import ForeignCall     ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
+import StgSyn          ( StgOp(..), stgArgType )
+import CoreSyn         ( AltCon(..) )
 import SMRep           ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
 import Outputable
 import Panic           ( panic )
 import FastTypes
 import Constants       ( wORD_SIZE, wORD_SIZE_IN_BITS )
 
-import Maybe           ( isJust )
-
 infixr 9 `thenFlt`
 \end{code}
 
@@ -108,18 +111,14 @@ mkAbsCStmtList' other r = other : r
 \end{code}
 
 \begin{code}
-mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
+mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC
 
-mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
- | isJust (nonemptyAbsC deflt_absc) 
-       = CSwitch scrutinee (adjust tagged_alts) deflt_absc
- | otherwise 
-       = CSwitch scrutinee (adjust rest) first_alt
+mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
+ = CSwitch scrutinee (adjust rest_alts) 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.
-   ((_,first_alt):rest) = tagged_alts
+   -- We use the first alt as the default.  Either it *is* the DEFAULT,
+   -- (which is always first if present), or the case is exhaustive,
+   -- in which case we can use the first as the default anyway
 
    -- Adjust the tags in the switch to start at zero.
    -- This is the convention used by primitive ops which return algebraic
@@ -128,8 +127,8 @@ mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
 
    -- We also need to convert to Literals to keep the CSwitch happy
    adjust tagged_alts
-     = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
-       | (tag, abs_c) <- tagged_alts ]
+     = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
+       | (DataAlt dc, abs_c) <- tagged_alts ]
 \end{code}
 
 %************************************************************************
@@ -348,8 +347,8 @@ flatAbsC (CSwitch discrim alts deflt)
        returnFlt ( (tag, alt_heres), alt_tops )
 
 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
-  |  is_dynamic                                 -- Emit a typedef if its a dynamic call
-     || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
+  |  is_dynamic                       -- Emit a typedef if its a dynamic call
+     || (opt_EmitCExternDecls) -- or we want extern decls
   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
   where
     is_dynamic = isDynamicTarget target
@@ -429,13 +428,6 @@ flatAbsC stmt@(CRetVector _ _ _ _)              = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CModuleInitBlock _ _ _)          = returnFlt (AbsCNop, stmt)
 \end{code}
 
-\begin{code}
-flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
-flat_maybe Nothing      = returnFlt (Nothing, AbsCNop)
-flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
-                         returnFlt (Just heres, tops)
-\end{code}
-
 %************************************************************************
 %*                                                                     *
 \subsection[flat-simultaneous]{Doing things simultaneously}
@@ -612,6 +604,7 @@ mkHalfWord_HIADDR res arg
      let 
         hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
 
+#        if WORDS_BIGENDIAN
          a_hw_mask1
             = CMachOpStmt t_hw_mask1
                           MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
@@ -619,12 +612,11 @@ mkHalfWord_HIADDR res arg
             = CMachOpStmt t_hw_mask2
                           MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
          final
-#        if WORDS_BIGENDIAN
             = CSequential [ a_hw_mask1, a_hw_mask2,
                  CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
               ]
 #        else
-            = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
+         final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
 #        endif
      in
          returnFlt final
@@ -669,7 +661,7 @@ mk_OSBI_ref offw rep base idx
 
 
 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
-   = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res (mkDerefOff WordRep addr fixedHdrSize) idx
 
 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
@@ -1305,5 +1297,19 @@ translateOp [r] EqForeignObj [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
 translateOp [r] EqStablePtrOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
 
 translateOp _ _ _ = Nothing
+\end{code}
 
+
+\begin{code}
+shimFCallArg arg amode
+  | tycon == foreignObjPrimTyCon
+       = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+       = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
+  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+       = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
+  | otherwise = amode
+  where        
+       -- should be a tycon app, since this is a foreign call
+       tycon = tyConAppTyCon (repType (stgArgType arg))
 \end{code}