mixedPtrLocn, mixedTypeLocn
)
-import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute )
+import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
+ playThreadSafe, ccallConvAttribute )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
import ForeignCall ( ForeignCall(..) )
-import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, getPrimRepArrayElemSize )
+import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
import StgSyn ( StgOp(..) )
import BitSet ( BitSet, intBS )
import Outputable
-import GlaExts
+import FastString
import Util ( lengthExceeds, listLengthCmp )
-import Maybe ( isNothing, maybeToList )
-import ST
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+
+import GLAEXTS
+import MONAD_ST
infixr 9 `thenTE`
\end{code}
= hcat [ptext (cStmtMacroText macro), lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting
pprAbsC (CCallProfCtrMacro op as) _
- = hcat [ptext op, lparen,
+ = hcat [ftext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC (CCallProfCCMacro op as) _
- = hcat [ptext op, lparen,
+ = hcat [ftext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _
= hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern"))
info_lbl = infoTableLabelFromCI cl_info
ppr_payload [] = empty
- ppr_payload ls = comma <+>
- braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls)))
-
- ppr_item item
- | rep == VoidRep = text "0" -- might not even need this...
- | rep == FloatRep = ppr_amode (floatToWord item)
- | rep == DoubleRep = hcat (punctuate (text ", (L_)")
- (map ppr_amode (doubleToWords item)))
- | otherwise = ppr_amode item
+ ppr_payload ls =
+ comma <+>
+ (braces $ hsep $ punctuate comma $
+ map (text "(L_)" <>) (foldr ppr_item [] ls))
+
+ ppr_item item rest
+ | rep == VoidRep = rest
+ | rep == FloatRep = ppr_amode (floatToWord item) : rest
+ | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest
+ | otherwise = ppr_amode item : rest
where
- rep = getAmodeRep item
+ rep = getAmodeRep item
pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
(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]
]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
+
+ thread_macro_args = ppr_uniq_token <> comma <+>
+ text "rts" <> ppr (playThreadSafe safety)
ppr_uniq_token = text "tok_" <> ppr uniq
(pp_save_context, pp_restore_context)
| playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
- text "; SUSPEND_THREAD" <> parens ppr_uniq_token <> semi
- , text "RESUME_THREAD" <> parens ppr_uniq_token <> text ";}"
+ text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
+ , text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
= ppr_casm_results non_void_results
call_str = case target of
- CasmTarget str -> _UNPK_ str
+ CasmTarget str -> unpackFS str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
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
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}
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 ]
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")
cStmtMacroText PUSH_SEQ_FRAME = SLIT("PUSH_SEQ_FRAME")
cStmtMacroText UPDATE_SU_FROM_UPD_FRAME = SLIT("UPDATE_SU_FROM_UPD_FRAME")
cStmtMacroText SET_TAG = SLIT("SET_TAG")
+cStmtMacroText DATA_TO_TAGZH = SLIT("dataToTagzh")
cStmtMacroText REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT")
cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT")
cStmtMacroText REGISTER_DIMPORT = SLIT("REGISTER_DIMPORT")
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}
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}
\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)))
)
= 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))
]
= 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}
projects / ghc-hetmet.git / blobdiff