X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=fff3006be18b874bf4442cdcc172d3fe20192887;hb=ce9687a5f450014c5596b32de8e8a7b99b6389e8;hp=48a90b4b1b2098062a6a365de92ecd522247e3d7;hpb=d11e681f219f6e38c2e5bc87adfb66f82de5ea65;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 48a90b4..fff3006 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -26,8 +26,8 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import Constants ( mIN_UPD_SIZE, wORD_SIZE ) -import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute ) +import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, + playThreadSafe, ccallConvAttribute ) import CLabel ( externallyVisibleCLabel, needsCDecl, pprCLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, @@ -45,11 +45,11 @@ import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) import DataCon ( dataConWrapId ) -import Maybes ( Maybe012(..), maybe012ToList, maybeToBool, catMaybes ) +import Maybes ( maybeToBool, catMaybes ) 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, @@ -58,10 +58,14 @@ import UniqSet ( emptyUniqSet, elementOfUniqSet, import StgSyn ( StgOp(..) ) import BitSet ( BitSet, intBS ) import Outputable -import GlaExts -import Util ( nOfThem, lengthExceeds, listLengthCmp ) -import Maybe ( isNothing ) +import FastString +import Util ( lengthExceeds, listLengthCmp ) +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST +#endif + +import GLAEXTS import ST infixr 9 `thenTE` @@ -254,41 +258,8 @@ pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _ -- NEW CASES FOR EXPANDED PRIMOPS --- We have to deal with some of these specially -pprAbsC (CMachOpStmt (Just1 res) (MO_ReadOSBI offw scaleRep) - [baseAmode, indexAmode] maybe_vols) - _ - | isNothing maybe_vols - = hcat [ -- text " /* ReadOSBI */ ", - ppr_amode res, equals, - ppr_array_expression offw scaleRep baseAmode indexAmode, - semi ] - | otherwise - = panic "pprAbsC:MO_ReadOSBI -- out-of-line array indexing ?!?!" - -pprAbsC (CMachOpStmt Just0 (MO_WriteOSBI offw scaleRep) - [baseAmode, indexAmode, vAmode] maybe_vols) - _ - | isNothing maybe_vols - = hcat [ -- text " /* WriteOSBI */ ", - ppr_array_expression offw scaleRep baseAmode indexAmode, - equals, pprAmode vAmode, - semi ] - | otherwise - = panic "pprAbsC:MO_WriteOSBI -- out-of-line array indexing ?!?!" - -pprAbsC (CMachOpStmt (Just2 res carry) mop [arg1,arg2] maybe_vols) _ - | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC] - = hcat [ pprMachOp_for_C mop, - lparen, - ppr_amode res, comma, ppr_amode carry, comma, - pprAmode arg1, comma, pprAmode arg2, - rparen, semi ] - --- The rest generically. - -pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1,arg2] maybe_vols) _ - = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr] +pprAbsC stmt@(CMachOpStmt res mop [arg1,arg2] maybe_vols) _ + = let prefix_fn = mop `elem` [MO_Dbl_Pwr, MO_Flt_Pwr, MO_NatS_MulMayOflo] in case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> saves $$ @@ -302,7 +273,7 @@ pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1,arg2] maybe_vols) _ $$ restores } -pprAbsC stmt@(CMachOpStmt (Just1 res) mop [arg1] maybe_vols) _ +pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _ = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> saves $$ hcat [ppr_amode res, equals, @@ -343,10 +314,10 @@ pprAbsC (CMacroStmt macro as) _ = 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")) @@ -450,8 +421,9 @@ pprAbsC (CInitHdr cl_info amode cost_centre size) _ pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info - -pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ + + +pprAbsC stmt@(CStaticClosure cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ pp_exts, @@ -464,37 +436,27 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ ppLocalnessMacro True{-include dyn-} info_lbl, char ')' ], - nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)), + nest 2 (ppr_payload amodes), ptext SLIT("};") ] } where - info_lbl = infoTableLabelFromCI cl_info + closure_lbl = closureLabelFromCI cl_info + 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 - upd_reqd = closureUpdReqd cl_info - - padding_wds - | not upd_reqd = [] - | otherwise = case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed -> - nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s - - -- always have a static link field, it's used to save the closure's - -- info pointer when we're reverting CAFs (see comment in Storage.c) - static_link_field - | upd_reqd || staticClosureNeedsLink cl_info = [mkIntCLit 0] - | otherwise = [] pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ = vcat [ @@ -634,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] @@ -664,6 +627,7 @@ pprMachOp_for_C MO_NatU_Gt = text ">" pprMachOp_for_C MO_NatU_Lt = text "<" pprMachOp_for_C MO_NatS_Mul = char '*' +pprMachOp_for_C MO_NatS_MulMayOflo = text "mulIntMayOflo" pprMachOp_for_C MO_NatS_Quot = char '/' pprMachOp_for_C MO_NatS_Rem = char '%' pprMachOp_for_C MO_NatS_Neg = char '-' @@ -672,10 +636,6 @@ pprMachOp_for_C MO_NatU_Mul = char '*' pprMachOp_for_C MO_NatU_Quot = char '/' pprMachOp_for_C MO_NatU_Rem = char '%' -pprMachOp_for_C MO_NatS_AddC = text "addIntCzh" -pprMachOp_for_C MO_NatS_SubC = text "subIntCzh" -pprMachOp_for_C MO_NatS_MulC = text "mulIntCzh" - pprMachOp_for_C MO_Nat_And = text "&" pprMachOp_for_C MO_Nat_Or = text "|" pprMachOp_for_C MO_Nat_Xor = text "^" @@ -773,23 +733,8 @@ pprMachOp_for_C MO_8U_to_NatU = text "(StgWord8)(StgWord)" pprMachOp_for_C MO_16U_to_NatU = text "(StgWord16)(StgWord)" pprMachOp_for_C MO_32U_to_NatU = text "(StgWord32)(StgWord)" -pprMachOp_for_C (MO_ReadOSBI _ _) = panic "pprMachOp_for_C:MO_ReadOSBI" -pprMachOp_for_C (MO_WriteOSBI _ _) = panic "pprMachOp_for_C:MO_WriteOSBI" - - --- Helper for printing array expressions. -ppr_array_expression offw scaleRep baseAmode indexAmode - -- create: - -- * (scaleRep*) ( - -- ((char*)baseAmode) + offw*bytes_per_word + indexAmode*bytes_per_scaleRep - -- ) - = let offb = parens (int offw <> char '*' <> int wORD_SIZE) - indb = parens (parens (pprAmode indexAmode) - <> char '*' <> int (getPrimRepArrayElemSize scaleRep)) - baseb = text "(char*)" <> parens (pprAmode baseAmode) - addr = parens baseb <+> char '+' <+> offb <+> char '+' <+> indb - in - char '*' <> parens (ppr scaleRep <> char '*') <> parens addr +pprMachOp_for_C MO_8U_to_32U = text "(StgWord32)" +pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)" ppLocalness lbl @@ -1000,9 +945,14 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs ] 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_ id; SUSPEND_THREAD(id);" - , text "RESUME_THREAD(id);}" + | playSafe safety = ( text "{ I_" <+> ppr_uniq_token <> + 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) @@ -1027,7 +977,7 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs = 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) @@ -1045,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 @@ -1063,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} @@ -1195,15 +1123,15 @@ Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} pprAssign FloatRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] pprAssign DoubleRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] pprAssign Int64Rep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] pprAssign Word64Rep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] \end{code} Lastly, the question is: will the C compiler think the types of the @@ -1236,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 ] @@ -1272,13 +1193,13 @@ question.) \begin{code} pprAmode (CVal reg_rel FloatRep) - = hcat [ text "PK_FLT(", ppr_amode (CAddr reg_rel), rparen ] + = hcat [ text "PK_FLT((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] pprAmode (CVal reg_rel DoubleRep) - = hcat [ text "PK_DBL(", ppr_amode (CAddr reg_rel), rparen ] + = hcat [ text "PK_DBL((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] pprAmode (CVal reg_rel Int64Rep) - = hcat [ text "PK_Int64(", ppr_amode (CAddr reg_rel), rparen ] + = hcat [ text "PK_Int64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] pprAmode (CVal reg_rel Word64Rep) - = hcat [ text "PK_Word64(", ppr_amode (CAddr reg_rel), rparen ] + = hcat [ text "PK_Word64((W_*)", parens (ppr_amode (CAddr reg_rel)), rparen ] \end{code} Next comes the case where there is some other cast need, and the @@ -1308,9 +1229,8 @@ That is, the indexing is done in units of kind1, but the resulting amode has kind2. \begin{code} -ppr_amode (CMem rep addr) - = let txt_rep = pprPrimKind rep - in hcat [ char '*', parens (txt_rep <> char '*'), parens (ppr_amode addr) ] +ppr_amode CBytesPerWord + = text "(sizeof(void*))" ppr_amode (CVal reg_rel@(CIndex _ _ _) kind) = case (pprRegRelative False{-no sign wanted-} reg_rel) of @@ -1360,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") @@ -1370,6 +1293,7 @@ cStmtMacroText PUSH_UPD_FRAME = SLIT("PUSH_UPD_FRAME") 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") @@ -1534,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} @@ -1715,7 +1629,7 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _) where info_lbl = infoTableLabelFromCI cl_info -ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (maybe012ToList res ++ args) +ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (res : args) ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args) ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc @@ -1737,7 +1651,7 @@ ppr_decls_AbsC (CCallProfCtrMacro _ amodes) = ppr_decls_Amodes [] -- *****!!! -- no real reason to, anyway. ppr_decls_AbsC (CCallProfCCMacro _ amodes) = ppr_decls_Amodes amodes -ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes) +ppr_decls_AbsC (CStaticClosure closure_info cost_centre amodes) -- ToDo: strictly speaking, should chk "cost_centre" amode = ppr_decls_Amodes amodes @@ -1763,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} @@ -1854,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))) ) @@ -1870,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)) ] @@ -1880,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}