[project @ 2002-11-22 07:43:29 by matthewc]

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

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index c08740c..58cf18f 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -58,11 +58,15 @@ import UniqSet              ( emptyUniqSet, elementOfUniqSet,
 import StgSyn          ( StgOp(..) )
 import BitSet          ( BitSet, intBS )
 import Outputable
-import GlaExts
 import FastString
 import Util            ( lengthExceeds, listLengthCmp )
 
-import ST
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+
+import GLAEXTS
+import MONAD_ST
 
 infixr 9 `thenTE`
 \end{code}
@@ -592,9 +596,10 @@ pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
                      (ptext SLIT("RET_VEC_BIG"))
 
 
-pprAbsC stmt@(CModuleInitBlock lbl code) _
+pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _
   = vcat [
-       ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl),
+       ptext SLIT("START_MOD_INIT") <> 
+           parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl),
        case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts },
        pprAbsC code (costs code),
        hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen]
@@ -990,13 +995,8 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
                  hcat (punctuate comma ccall_fun_args),
                text "));"
        ])
-\end{code}
 
-If the argument is a heap object, we need to reach inside and pull out
-the bit the C world wants to see.  The only heap objects which can be
-passed are @Array@s and @ByteArray@s.
 
-\begin{code}
 ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
     -- (a) decl and assignment, (b) local var to be used later
 
@@ -1008,25 +1008,8 @@ ppr_casm_arg amode a_num
 
        local_var  = (<>) (ptext SLIT("_ccall_arg")) (int a_num)
 
-       (arg_type, pp_amode2)
-         = case a_kind of
-
-             -- for array arguments, pass a pointer to the body of the array
-             -- (PTRS_ARR_CTS skips over all the header nonsense)
-             ArrayRep      -> (pp_kind,
-                               hcat [ptext SLIT("PTRS_ARR_CTS"),char '(', pp_amode, rparen])
-             ByteArrayRep -> (pp_kind,
-                               hcat [ptext SLIT("BYTE_ARR_CTS"),char '(', pp_amode, rparen])
-
-             -- for ForeignObj, use FOREIGN_OBJ_DATA to fish out the contents.
-             ForeignObjRep -> (pp_kind,
-                               hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"),
-                                     char '(', pp_amode, char ')'])
-
-             other         -> (pp_kind, pp_amode)
-
        declare_local_var
-         = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ]
+         = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ]
     in
     (declare_local_var, local_var)
 \end{code}
@@ -1181,13 +1164,6 @@ pprAssign kind dest src
                text "(P_)(",   -- Here is the cast
                ppr_amode src, pp_paren_semi ]
 
-pprAssign ByteArrayRep dest src
-  | mixedPtrLocn src
-    -- Add in a cast iff the source is mixed
-  = hcat [ ppr_amode dest, equals,
-               text "(StgByteArray)(", -- Here is the cast
-               ppr_amode src, pp_paren_semi ]
-
 pprAssign kind other_dest src
   = hcat [ ppr_amode other_dest, equals,
                pprAmode  src, semi ]
@@ -1304,6 +1280,9 @@ cExprMacroText ARG_TAG                    = SLIT("ARG_TAG")
 cExprMacroText GET_TAG                 = SLIT("GET_TAG")
 cExprMacroText UPD_FRAME_UPDATEE       = SLIT("UPD_FRAME_UPDATEE")
 cExprMacroText CCS_HDR                 = SLIT("CCS_HDR")
+cExprMacroText BYTE_ARR_CTS            = SLIT("BYTE_ARR_CTS")
+cExprMacroText PTRS_ARR_CTS            = SLIT("PTRS_ARR_CTS")
+cExprMacroText ForeignObj_CLOSURE_DATA  = SLIT("ForeignObj_CLOSURE_DATA")
 
 cStmtMacroText ARGS_CHK                        = SLIT("ARGS_CHK")
 cStmtMacroText ARGS_CHK_LOAD_NODE      = SLIT("ARGS_CHK_LOAD_NODE")
@@ -1479,16 +1458,6 @@ pprUnionTag FloatRep             = char 'f'
 pprUnionTag DoubleRep          = panic "pprUnionTag:Double?"
 
 pprUnionTag StablePtrRep       = char 'p'
-pprUnionTag StableNameRep      = char 'p'
-pprUnionTag WeakPtrRep         = char 'p'
-pprUnionTag ForeignObjRep      = char 'p'
-pprUnionTag PrimPtrRep         = char 'p'
-
-pprUnionTag ThreadIdRep                = char 't'
-
-pprUnionTag ArrayRep           = char 'p'
-pprUnionTag ByteArrayRep       = char 'b'
-pprUnionTag BCORep             = char 'p'
 
 pprUnionTag _                   = panic "pprUnionTag:Odd kind"
 \end{code}
@@ -1708,7 +1677,7 @@ ppr_decls_AbsC (CSRT _ closure_lbls)
 
 ppr_decls_AbsC (CRetDirect     _ code _ _)   = ppr_decls_AbsC code
 ppr_decls_AbsC (CRetVector _ amodes _ _)     = ppr_decls_Amodes amodes
-ppr_decls_AbsC (CModuleInitBlock _ code)     = ppr_decls_AbsC code
+ppr_decls_AbsC (CModuleInitBlock _ _ code)   = ppr_decls_AbsC code
 
 ppr_decls_AbsC (_) = returnTE (Nothing, Nothing)
 \end{code}
@@ -1799,13 +1768,46 @@ can safely initialise to static locations.
 \begin{code}
 big_doubles = (getPrimRepSize DoubleRep) /= 1
 
--- floatss are always 1 word
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
+castFloatToIntArray = castSTUArray
+
+castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
+castDoubleToIntArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readIntArray :: STUArray s Int Int -> Int -> ST s Int
+readIntArray = readArray
+
+#else
+
+castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToIntArray = return
+
+castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castDoubleToIntArray = return
+
+#endif
+
+-- floats are always 1 word
 floatToWord :: CAddrMode -> CAddrMode
 floatToWord (CLit (MachFloat r))
   = runST (do
        arr <- newFloatArray ((0::Int),0)
        writeFloatArray arr 0 (fromRational r)
-       i <- readIntArray arr 0
+       arr' <- castFloatToIntArray arr
+       i <- readIntArray arr' 0
        return (CLit (MachInt (toInteger i)))
     )
 
@@ -1815,8 +1817,9 @@ doubleToWords (CLit (MachDouble r))
   = runST (do
        arr <- newDoubleArray ((0::Int),1)
        writeDoubleArray arr 0 (fromRational r)
-       i1 <- readIntArray arr 0
-       i2 <- readIntArray arr 1
+       arr' <- castDoubleToIntArray arr
+       i1 <- readIntArray arr' 0
+       i2 <- readIntArray arr' 1
        return [ CLit (MachInt (toInteger i1))
               , CLit (MachInt (toInteger i2))
               ]
@@ -1825,7 +1828,8 @@ doubleToWords (CLit (MachDouble r))
   = runST (do
        arr <- newDoubleArray ((0::Int),0)
        writeDoubleArray arr 0 (fromRational r)
-       i <- readIntArray arr 0
+       arr' <- castDoubleToIntArray arr
+       i <- readIntArray arr' 0
        return [ CLit (MachInt (toInteger i)) ]
     )
 \end{code}