X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=765971f244ac41050295a531831bc7f3843138d8;hb=79abe0acae28895eeb8a762dcf5867b84982a27c;hp=d0b396eeec1a957a187626fda30415b3c16413ce;hpb=ed4cd6d403d932026f38608f81c3a8872e38b2ce;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index d0b396e..765971f 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -26,36 +26,40 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC, ) import Constants ( mIN_UPD_SIZE ) -import CallConv ( CallConv, callConvAttribute, cCallConv ) -import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, - isReadOnly, needsCDecl, pprCLabel, - mkReturnInfoLabel, mkReturnPtLabel, - CLabel, CLabelType(..), labelType +import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute ) +import CLabel ( externallyVisibleCLabel, + needsCDecl, pprCLabel, + mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, + mkClosureLabel, mkErrorStdEntryLabel, + CLabel, CLabelType(..), labelType, labelDynamic ) -import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros ) +import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl ) import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) -import CStrings ( stringToC ) +import CStrings ( pprStringInCStyle, pprCLabelString ) import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) -import Const ( Literal(..) ) +import Literal ( Literal(..) ) +import TyCon ( tyConDataCons ) +import Name ( NamedThing(..) ) +import DataCon ( dataConWrapId ) import Maybes ( maybeToBool, catMaybes ) -import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) -import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep ) -import SMRep ( getSMRepStr ) +import PrimOp ( primOpNeedsWrapper ) +import ForeignCall ( ForeignCall(..) ) +import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) +import SMRep ( pprSMRep ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, UniqSet ) -import StgSyn ( SRT(..) ) -import BitSet ( intBS ) +import StgSyn ( StgOp(..) ) +import BitSet ( BitSet, intBS ) import Outputable -import Util ( nOfThem ) -import Addr ( Addr ) +import GlaExts +import Util ( nOfThem, lengthExceeds, listLengthCmp ) import ST -import MutableArray infixr 9 `thenTE` \end{code} @@ -139,13 +143,14 @@ pprAbsC (CReturn am return_info) c (hcat [text jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> hcat [char '(', pprAmode am, rparen] + DirectReturn -> hcat [ptext SLIT("ENTRY_CODE"), lparen, + pprAmode am, rparen] DynamicVectoredReturn am' -> mk_vector (pprAmode am') StaticVectoredReturn n -> mk_vector (int n) -- Always positive - mk_vector x = hcat [text "RET_VEC", char '(', pprAmode am, comma, + mk_vector x = hcat [ptext SLIT("RET_VEC"), char '(', pprAmode am, comma, x, rparen ] -pprAbsC (CSplitMarker) _ = ptext SLIT("/* SPLIT */") +pprAbsC (CSplitMarker) _ = ptext SLIT("__STG_SPLIT_MARKER") -- we optimise various degenerate cases of CSwitches. @@ -171,8 +176,8 @@ pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt do_if_stmt discrim tag alt_code dc c -- What problem is the re-ordering trying to solve ? -pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), - (tag2@(MachInt i2 _), alt_code2)] deflt) c +pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1), + (tag2@(MachInt i2), alt_code2)] deflt) c | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) = if (i1 == 0) then do_if_stmt discrim tag1 alt_code1 alt_code2 c @@ -208,10 +213,10 @@ pprAbsC (CSwitch discrim alts deflt) c -- general case -- Costs for addressing header of switch and cond. branching -- HWL switch_head_cost = addrModeCosts discrim Rhs + (Cost (0, 1, 0, 0, 0)) -pprAbsC stmt@(COpStmt results op@(CCallOp _ _ _ _) args vol_regs) _ - = pprCCall op args results vol_regs +pprAbsC stmt@(COpStmt results (StgFCallOp fcall uniq) args vol_regs) _ + = pprFCall fcall uniq args results vol_regs -pprAbsC stmt@(COpStmt results op args vol_regs) _ +pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _ = let non_void_args = grab_non_void_amodes args non_void_results = grab_non_void_amodes results @@ -223,18 +228,18 @@ pprAbsC stmt@(COpStmt results op args vol_regs) _ the_op = ppr_op_call non_void_results non_void_args -- liveness mask is *in* the non_void_args in - case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) -> if primOpNeedsWrapper op then + case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) -> vcat [ pp_saves, the_op, pp_restores ] + } else the_op - } where ppr_op_call results args - = hcat [ pprPrimOp op, lparen, + = hcat [ ppr op, lparen, hcat (punctuate comma (map ppr_op_result results)), if null results || null args then empty else comma, hcat (punctuate comma (map pprAmode args)), @@ -251,28 +256,24 @@ pprAbsC stmt@(CSRT lbl closures) c $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures))) <> ptext SLIT("};") } - where pp_closure_lbl lbl = char '&' <> pprCLabel lbl pprAbsC stmt@(CBitmap lbl mask) c - = vcat [ - hcat [ ptext SLIT("BITMAP"), lparen, - pprCLabel lbl, comma, - int (length mask), - rparen ], - hcat (punctuate comma (map (int.intBS) mask)), - ptext SLIT("}};") - ] + = pp_bitmap_switch mask semi $ + hcat [ ptext SLIT("BITMAP"), lparen, + pprCLabel lbl, comma, + int (length mask), comma, + pp_bitmap mask, rparen ] pprAbsC (CSimultaneous abs_c) c = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] pprAbsC (CCheck macro as code) c - = hcat [text (show macro), lparen, + = hcat [ptext (cCheckMacroText macro), lparen, hcat (punctuate comma (map ppr_amode as)), comma, pprAbsC code c, pp_paren_semi ] pprAbsC (CMacroStmt macro as) _ - = hcat [text (show macro), lparen, + = 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, @@ -280,69 +281,109 @@ pprAbsC (CCallProfCtrMacro op as) _ pprAbsC (CCallProfCCMacro op as) _ = hcat [ptext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv) results args) _ - = hsep [ ptext SLIT("typedef") +pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _ + = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern")) , ccall_res_ty , fun_nm , parens (hsep (punctuate comma ccall_decl_ty_args)) ] <> semi where - fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty) + {- + In the non-casm case, to ensure that we're entering the given external + entry point using the correct calling convention, we have to do the following: + + - When entering via a function pointer (the `dynamic' case) using the specified + calling convention, we emit a typedefn declaration attributed with the + calling convention to use together with the result and parameter types we're + assuming. Coerce the function pointer to this type and go. + + - to enter the function at a given code label, we emit an extern declaration + for the label here, stating the calling convention together with result and + argument types we're assuming. + + The C compiler will hopefully use this extern declaration to good effect, + reporting any discrepancies between our extern decl and any other that + may be in scope. + + Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for + the external function `foo' use the calling convention of the first `foo' + prototype it encounters (nor does it complain about conflicting attribute + declarations). The consequence of this is that you cannot override the + calling convention of `foo' using an extern declaration (you'd have to use + a typedef), but why you would want to do such a thing in the first place + is totally beyond me. + + ToDo: petition the gcc folks to add code to warn about conflicting attribute + declarations. + + -} + + fun_nm + | is_tdef = parens (text (ccallConvAttribute cconv) <+> char '*' <> ccall_fun_ty) + | otherwise = text (ccallConvAttribute cconv) <+> ccall_fun_ty ccall_fun_ty = case op_str of - Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u + DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq + StaticTarget x -> pprCLabelString x ccall_res_ty = case non_void_results of [] -> ptext SLIT("void") - [amode] -> text (showPrimRep (getAmodeRep amode)) + [amode] -> ppr (getAmodeRep amode) _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty" - ccall_decl_ty_args = tail ccall_arg_tys - ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args + ccall_decl_ty_args + | is_tdef = tail ccall_arg_tys + | otherwise = ccall_arg_tys + + ccall_arg_tys = map (ppr . getAmodeRep) non_void_args -- the first argument will be the "I/O world" token (a VoidRep) -- all others should be non-void non_void_args = - let nvas = tail args + let nvas = init args in ASSERT (all non_void nvas) nvas -- there will usually be two results: a (void) state which we -- should ignore and a (possibly void) result. non_void_results = let nvrs = grab_non_void_amodes results - in ASSERT (length nvrs <= 1) nvrs + in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs -pprAbsC (CCodeBlock label abs_C) _ +pprAbsC (CCodeBlock lbl abs_C) _ = if not (maybeToBool(nonemptyAbsC abs_C)) then - pprTrace "pprAbsC: curious empty code block for" (pprCLabel label) empty + pprTrace "pprAbsC: curious empty code block for" (pprCLabel lbl) empty else case (pprTempAndExternDecls abs_C) of { (pp_temps, pp_exts) -> vcat [ - hcat [text (if (externallyVisibleCLabel label) + empty, + pp_exts, + hcat [text (if (externallyVisibleCLabel lbl) then "FN_(" -- abbreviations to save on output else "IFN_("), - pprCLabel label, text ") {"], + pprCLabel lbl, text ") {"], - pp_exts, pp_temps, + pp_temps, nest 8 (ptext SLIT("FB_")), nest 8 (pprAbsC abs_C (costs abs_C)), nest 8 (ptext SLIT("FE_")), - char '}' ] + char '}', + char ' ' ] } -pprAbsC (CInitHdr cl_info reg_rel cost_centre) _ +pprAbsC (CInitHdr cl_info amode cost_centre size) _ = hcat [ ptext SLIT("SET_HDR_"), char '(', - ppr_amode (CAddr reg_rel), comma, + ppr_amode amode, comma, pprCLabelAddr info_lbl, comma, - if_profiling (pprAmode cost_centre), + if_profiling (pprAmode cost_centre), comma, + if_profiling (int size), pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info - + pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ @@ -353,10 +394,10 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ pprCLabel info_lbl, comma, if_profiling (pprAmode cost_centre), comma, ppLocalness closure_lbl, comma, - ppLocalnessMacro info_lbl, + ppLocalnessMacro True{-include dyn-} info_lbl, char ')' ], - nest 2 (ppr_payload (amodes ++ padding_wds)), + nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)), ptext SLIT("};") ] } where @@ -375,16 +416,20 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ where rep = getAmodeRep item - -- always at least one padding word: this is the static link field for - -- the garbage collector. - padding_wds = - if not (closureUpdReqd cl_info) then - [mkIntCLit 0] - else - case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed -> - nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s + 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 -pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _ + -- 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 [ hcat [ ptext SLIT("INFO_TABLE"), @@ -400,8 +445,8 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _ pprCLabel slow_lbl, comma, pp_rest, {- ptrs,nptrs,[srt,]type,-} comma, - ppLocalness info_lbl, comma, - ppLocalnessMacro slow_lbl, comma, + ppLocalness info_lbl, comma, + ppLocalnessMacro True{-include dyn-} slow_lbl, comma, if_profiling pp_descr, comma, if_profiling pp_type, @@ -432,7 +477,11 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _ is_constr = maybeToBool maybe_tag (Just tag) = maybe_tag - needs_srt = has_srt srt && needsSRT cl_info + srt = closureSRT cl_info + needs_srt = case srt of + NoC_SRT -> False + other -> True + size = closureNonHdrSize cl_info @@ -450,10 +499,19 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _ else empty, type_str ] - type_str = text (getSMRepStr (closureSMRep cl_info)) + type_str = pprSMRep (closureSMRep cl_info) - pp_descr = hcat [char '"', text (stringToC cl_descr), char '"'] - pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"'] + pp_descr = pprStringInCStyle cl_descr + pp_type = pprStringInCStyle (closureTypeDescr cl_info) + +pprAbsC stmt@(CClosureTbl tycon) _ + = vcat ( + ptext SLIT("CLOSURE_TBL") <> + lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen : + punctuate comma ( + map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon) + ) + ) $$ ptext SLIT("};") pprAbsC stmt@(CRetDirect uniq code srt liveness) _ = vcat [ @@ -463,90 +521,96 @@ pprAbsC stmt@(CRetDirect uniq code srt liveness) _ pprCLabel entry_lbl, comma, pp_liveness liveness, comma, -- bitmap pp_srt_info srt, -- SRT - ptext type_str, comma, -- closure type + closure_type, comma, -- closure type ppLocalness info_lbl, comma, -- info table storage class - ppLocalnessMacro entry_lbl, comma, -- entry pt storage class + ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class int 0, comma, int 0, text ");" ], pp_code ] where - info_lbl = mkReturnInfoLabel uniq - entry_lbl = mkReturnPtLabel uniq + info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq - pp_code = let stuff = CCodeBlock entry_lbl code in - pprAbsC stuff (costs stuff) + pp_code = let stuff = CCodeBlock entry_lbl code in + pprAbsC stuff (costs stuff) - type_str = case liveness of - LvSmall _ -> SLIT("RET_SMALL") - LvLarge _ -> SLIT("RET_BIG") + closure_type = pp_liveness_switch liveness + (ptext SLIT("RET_SMALL")) + (ptext SLIT("RET_BIG")) -pprAbsC stmt@(CRetVector label amodes srt liveness) _ - = vcat [ - pp_vector, +pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ + = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> + vcat [ + pp_exts, hcat [ - ptext SLIT(" }"), comma, ptext SLIT("\n VEC_INFO_TABLE"), - lparen, - pp_liveness liveness, comma, -- bitmap liveness mask - pp_srt_info srt, -- SRT - ptext type_str, -- or big, depending on the size - -- of the liveness mask. - rparen - ], - text "};" + ptext SLIT("VEC_INFO_") <> int size, + lparen, + pprCLabel lbl, comma, + pp_liveness liveness, comma, -- bitmap liveness mask + pp_srt_info srt, -- SRT + closure_type, comma, + ppLocalness lbl, comma + ], + nest 2 (sep (punctuate comma (map ppr_item amodes))), + text ");" ] + } where - pp_vector = - case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - vcat [ - pp_exts, - hcat [ppLocalness label, - ptext SLIT(" vec_info_"), int size, space, - pprCLabel label, text "= { {" - ], - nest 2 (sep (punctuate comma (map ppr_item (reverse amodes)))) - ] } - ppr_item item = (<>) (text "(F_) ") (ppr_amode item) size = length amodes - type_str = case liveness of - LvSmall _ -> SLIT("RET_VEC_SMALL") - LvLarge _ -> SLIT("RET_VEC_BIG") + closure_type = pp_liveness_switch liveness + (ptext SLIT("RET_VEC_SMALL")) + (ptext SLIT("RET_VEC_BIG")) +pprAbsC stmt@(CModuleInitBlock lbl code) _ + = vcat [ + ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl), + case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts }, + pprAbsC code (costs code), + hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen] + ] + pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs \end{code} \begin{code} -ppLocalness label - = (<>) static const - where - static = if (externallyVisibleCLabel label) +ppLocalness lbl + = if (externallyVisibleCLabel lbl) then empty else ptext SLIT("static ") - const = if not (isReadOnly label) - then empty - else ptext SLIT("const") -- Horrible macros for declaring the types and locality of labels (see -- StgMacros.h). -ppLocalnessMacro clabel = +ppLocalnessMacro include_dyn_prefix clabel = hcat [ - char (if externallyVisibleCLabel clabel then 'E' else 'I'), - case labelType clabel of - InfoTblType -> ptext SLIT("I_") - ClosureType -> ptext SLIT("C_") - CodeType -> ptext SLIT("F_") - DataType -> ptext SLIT("D_") <> - if isReadOnly clabel - then ptext SLIT("RO_") - else empty + visiblity_prefix, + dyn_prefix, + case label_type of + ClosureType -> ptext SLIT("C_") + CodeType -> ptext SLIT("F_") + InfoTblType -> ptext SLIT("I_") + ClosureTblType -> ptext SLIT("CP_") + DataType -> ptext SLIT("D_") ] + where + is_visible = externallyVisibleCLabel clabel + label_type = labelType clabel + + visiblity_prefix + | is_visible = char 'E' + | otherwise = char 'I' + + dyn_prefix + | include_dyn_prefix && labelDynamic clabel = char 'D' + | otherwise = empty + \end{code} \begin{code} @@ -575,35 +639,29 @@ ppr_vol_regs (r:rs) (($$) ((<>) (ptext SLIT("CALLER_SAVE_")) pp_reg) more_saves, ($$) ((<>) (ptext SLIT("CALLER_RESTORE_")) pp_reg) more_restores) --- pp_basic_{saves,restores}: The BaseReg, SpA, SuA, SpB, SuB, Hp and +-- pp_basic_{saves,restores}: The BaseReg, Sp, Su, Hp and -- HpLim (see StgRegs.lh) may need to be saved/restored around CCalls, -- depending on the platform. (The "volatile regs" stuff handles all -- other registers.) Just be *sure* BaseReg is OK before trying to do -- anything else. The correct sequence of saves&restores are -- encoded by the CALLER_*_SYSTEM macros. -pp_basic_saves - = vcat - [ ptext SLIT("CALLER_SAVE_Base") - , ptext SLIT("CALLER_SAVE_SYSTEM") - ] - +pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM") pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} \begin{code} -has_srt (_, NoSRT) = False -has_srt _ = True - -pp_srt_info srt = - case srt of - (lbl, NoSRT) -> - hcat [ int 0, comma, - int 0, comma, - int 0, comma ] - (lbl, SRT off len) -> - hcat [ pprCLabel lbl, comma, - int off, comma, - int len, comma ] +pp_srt_info NoC_SRT = hcat [ int 0, comma, + int 0, comma, + int 0, comma ] +pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma, + int off, comma, + int len, comma ] +\end{code} + +\begin{code} +pp_closure_lbl lbl + | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl) + | otherwise = char '&' <> pprCLabel lbl \end{code} \begin{code} @@ -622,10 +680,10 @@ do_if_stmt discrim tag alt_code deflt c = case tag of -- This special case happens when testing the result of a comparison. -- We can just avoid some redundant clutter in the output. - MachInt n _ | n==0 -> ppr_if_stmt (pprAmode discrim) + MachInt n | n==0 -> ppr_if_stmt (pprAmode discrim) deflt alt_code (addrModeCosts discrim Rhs) c - other -> let + other -> let cond = hcat [ pprAmode discrim , ptext SLIT(" == ") , tcast @@ -639,10 +697,9 @@ do_if_stmt discrim tag alt_code deflt c -- in C (when minInt is a number not a constant -- expression which evaluates to it.) -- - tcast = - case other of - MachInt _ signed | signed -> ptext SLIT("(I_)") - _ -> empty + tcast = case other of + MachInt _ -> ptext SLIT("(I_)") + _ -> empty in ppr_if_stmt cond alt_code deflt @@ -715,14 +772,13 @@ Amendment to the above: if we can GC, we have to: that the runtime check that PerformGC is being used sensibly will work. \begin{code} -pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs +pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs = vcat [ char '{', declare_local_vars, -- local var for *result* vcat local_arg_decls, pp_save_context, - declare_fun_extern, -- declare expected function type. - process_casm local_vars pp_non_void_args casm_str, + process_casm local_vars pp_non_void_args call_str, pp_restore_context, assign_results, char '}' @@ -730,111 +786,42 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs where (pp_saves, pp_restores) = ppr_vol_regs vol_regs (pp_save_context, pp_restore_context) - | may_gc = ( text "do { SaveThreadState();" - , text "LoadThreadState();} while(0);" - ) + | playSafe safety = ( text "{ I_ id; SUSPEND_THREAD(id);" + , text "RESUME_THREAD(id);}" + ) | otherwise = ( pp_basic_saves $$ pp_saves, pp_basic_restores $$ pp_restores) - non_void_args = - let nvas = tail args - in ASSERT (all non_void nvas) nvas - -- the first argument will be the "I/O world" token (a VoidRep) + non_void_args = + let nvas = init args + in ASSERT2 ( all non_void nvas, ppr call <+> hsep (map pprAmode args) ) + nvas + -- the last argument will be the "I/O world" token (a VoidRep) -- all others should be non-void non_void_results = let nvrs = grab_non_void_amodes results - in ASSERT (length nvrs <= 1) nvrs + in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs -- there will usually be two results: a (void) state which we -- should ignore and a (possibly void) result. (local_arg_decls, pp_non_void_args) = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ] - - {- - In the non-casm case, to ensure that we're entering the given external - entry point using the correct calling convention, we have to do the following: - - - When entering via a function pointer (the `dynamic' case) using the specified - calling convention, we emit a typedefn declaration attributed with the - calling convention to use together with the result and parameter types we're - assuming. Coerce the function pointer to this type and go. - - - to enter the function at a given code label, we emit an extern declaration - for the label here, stating the calling convention together with result and - argument types we're assuming. - - The C compiler will hopefully use this extern declaration to good effect, - reporting any discrepancies between our extern decl and any other that - may be in scope. - - Re: calling convention, notice that gcc (2.8.1 and egcs-1.0.2) will for - the external function `foo' use the calling convention of the first `foo' - prototype it encounters (nor does it complain about conflicting attribute - declarations). The consequence of this is that you cannot override the - calling convention of `foo' using an extern declaration (you'd have to use - a typedef), but why you would want to do such a thing in the first place - is totally beyond me. - - ToDo: petition the gcc folks to add code to warn about conflicting attribute - declarations. - - -} - declare_fun_extern - | is_dynamic || is_asm || not opt_EmitCExternDecls = empty - | otherwise = - hsep [ typedef_or_extern - , ccall_res_ty - , fun_nm - , parens (hsep (punctuate comma ccall_decl_ty_args)) - ] <> semi - where - typedef_or_extern - | is_dynamic = ptext SLIT("typedef") - | otherwise = ptext SLIT("extern") - - fun_nm - | is_dynamic = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty) - | otherwise = text (callConvAttribute cconv) <+> ptext asm_str - - -- leave out function pointer - ccall_decl_ty_args - | is_dynamic = tail ccall_arg_tys - | otherwise = ccall_arg_tys - - ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args - - ccall_res_ty = - case non_void_results of - [] -> ptext SLIT("void") - [amode] -> text (showPrimRep (getAmodeRep amode)) - _ -> panic "pprCCall: ccall_res_ty" - - ccall_fun_ty = - ptext SLIT("_ccall_fun_ty") <> - case op_str of - Right u -> ppr u - _ -> empty - (declare_local_vars, local_vars, assign_results) = ppr_casm_results non_void_results - (Left asm_str) = op_str - is_dynamic = - case op_str of - Left _ -> False - _ -> True + call_str = case target of + CasmTarget str -> _UNPK_ str + StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args + DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) - casm_str = if is_asm then _UNPK_ asm_str else ccall_str + ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..] + dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0") + -- Remainder only used for ccall - - fun_name - | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0") - | otherwise = ptext asm_str - - ccall_str = showSDoc + mk_ccall_str fun_name ccall_fun_args = showSDoc (hcat [ if null non_void_results then empty @@ -843,13 +830,6 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv) args results vol_regs hcat (punctuate comma ccall_fun_args), text "));" ]) - - ccall_fun_args - | is_dynamic = tail ccall_args - | otherwise = ccall_args - - ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..] - \end{code} If the argument is a heap object, we need to reach inside and pull out @@ -945,7 +925,7 @@ process_casm results args string = process results args string process [] _ "" = empty process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ - "\"\n(Try changing result type to PrimIO ()\n") + "\"\n(Try changing result type to IO ()\n") process ress args ('%':cs) = case cs of @@ -968,7 +948,7 @@ process_casm results args string = process results args string in case (read_int other) of [(num,css)] -> - if 0 <= num && num < length args + if num >= 0 && args `lengthExceeds` num then parens (args !! num) <> process ress args css else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n") _ -> error ("process_casm: not % while processing _casm_ \"" ++ string ++ "\".\n") @@ -1014,13 +994,13 @@ pprAssign Word64Rep dest@(CVal reg_rel _) src Lastly, the question is: will the C compiler think the types of the two sides of the assignment match? - We assume that the types will match - if neither side is a @CVal@ addressing mode for any register - which can point into the heap or B stack. + We assume that the types will match if neither side is a + @CVal@ addressing mode for any register which can point into + the heap or stack. -Why? Because the heap and B stack are used to store miscellaneous things, -whereas the A stack, temporaries, registers, etc., are only used for things -of fixed type. +Why? Because the heap and stack are used to store miscellaneous +things, whereas the temporaries, registers, etc., are only used for +things of fixed type. \begin{code} pprAssign kind (CReg (VanillaReg _ dest)) (CReg (VanillaReg _ src)) @@ -1098,6 +1078,29 @@ pprAmode amode = ppr_amode amode \end{code} +When we have an indirection through a CIndex, we have to be careful to +get the type casts right. + +this amode: + + CVal (CIndex kind1 base offset) kind2 + +means (in C speak): + + *(kind2 *)((kind1 *)base + offset) + +That is, the indexing is done in units of kind1, but the resulting +amode has kind2. + +\begin{code} +ppr_amode (CVal reg_rel@(CIndex _ _ _) kind) + = case (pprRegRelative False{-no sign wanted-} reg_rel) of + (pp_reg, Nothing) -> panic "ppr_amode: CIndex" + (pp_reg, Just offset) -> + hcat [ char '*', parens (pprPrimKind kind <> char '*'), + parens (pp_reg <> char '+' <> offset) ] +\end{code} + Now the rest of the cases for ``workhorse'' @ppr_amode@: \begin{code} @@ -1115,34 +1118,65 @@ ppr_amode (CReg magic_id) = pprMagicId magic_id ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_' -ppr_amode (CLbl label kind) = pprCLabelAddr label +ppr_amode (CLbl lbl kind) = pprCLabelAddr lbl ppr_amode (CCharLike ch) = hcat [ptext SLIT("CHARLIKE_CLOSURE"), char '(', pprAmode ch, rparen ] ppr_amode (CIntLike int) = hcat [ptext SLIT("INTLIKE_CLOSURE"), char '(', pprAmode int, rparen ] -ppr_amode (CString str) = hcat [char '"', text (stringToC (_UNPK_ str)), char '"'] - -- ToDo: are these *used* for anything? - ppr_amode (CLit lit) = pprBasicLit lit -ppr_amode (CLitLit str _) = ptext str - ppr_amode (CJoinPoint _) = panic "ppr_amode: CJoinPoint" -ppr_amode (CTableEntry base index kind) - = hcat [text "((", pprPrimKind kind, text " *)(", - ppr_amode base, text "))[(I_)(", ppr_amode index, - ptext SLIT(")]")] - ppr_amode (CMacroExpr pk macro as) - = parens (pprPrimKind pk) <+> - parens (text (show macro) <> + = parens (ptext (cExprMacroText macro) <> parens (hcat (punctuate comma (map pprAmode as)))) \end{code} +\begin{code} +cExprMacroText ENTRY_CODE = SLIT("ENTRY_CODE") +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") + +cStmtMacroText ARGS_CHK = SLIT("ARGS_CHK") +cStmtMacroText ARGS_CHK_LOAD_NODE = SLIT("ARGS_CHK_LOAD_NODE") +cStmtMacroText UPD_CAF = SLIT("UPD_CAF") +cStmtMacroText UPD_BH_UPDATABLE = SLIT("UPD_BH_UPDATABLE") +cStmtMacroText UPD_BH_SINGLE_ENTRY = SLIT("UPD_BH_SINGLE_ENTRY") +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 REGISTER_FOREIGN_EXPORT = SLIT("REGISTER_FOREIGN_EXPORT") +cStmtMacroText REGISTER_IMPORT = SLIT("REGISTER_IMPORT") +cStmtMacroText REGISTER_DIMPORT = SLIT("REGISTER_DIMPORT") +cStmtMacroText GRAN_FETCH = SLIT("GRAN_FETCH") +cStmtMacroText GRAN_RESCHEDULE = SLIT("GRAN_RESCHEDULE") +cStmtMacroText GRAN_FETCH_AND_RESCHEDULE= SLIT("GRAN_FETCH_AND_RESCHEDULE") +cStmtMacroText THREAD_CONTEXT_SWITCH = SLIT("THREAD_CONTEXT_SWITCH") +cStmtMacroText GRAN_YIELD = SLIT("GRAN_YIELD") + +cCheckMacroText HP_CHK_NP = SLIT("HP_CHK_NP") +cCheckMacroText STK_CHK_NP = SLIT("STK_CHK_NP") +cCheckMacroText HP_STK_CHK_NP = SLIT("HP_STK_CHK_NP") +cCheckMacroText HP_CHK_SEQ_NP = SLIT("HP_CHK_SEQ_NP") +cCheckMacroText HP_CHK = SLIT("HP_CHK") +cCheckMacroText STK_CHK = SLIT("STK_CHK") +cCheckMacroText HP_STK_CHK = SLIT("HP_STK_CHK") +cCheckMacroText HP_CHK_NOREGS = SLIT("HP_CHK_NOREGS") +cCheckMacroText HP_CHK_UNPT_R1 = SLIT("HP_CHK_UNPT_R1") +cCheckMacroText HP_CHK_UNBX_R1 = SLIT("HP_CHK_UNBX_R1") +cCheckMacroText HP_CHK_F1 = SLIT("HP_CHK_F1") +cCheckMacroText HP_CHK_D1 = SLIT("HP_CHK_D1") +cCheckMacroText HP_CHK_L1 = SLIT("HP_CHK_L1") +cCheckMacroText HP_CHK_UT_ALT = SLIT("HP_CHK_UT_ALT") +cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") +\end{code} + %************************************************************************ %* * \subsection[ppr-liveness-masks]{Liveness Masks} @@ -1150,11 +1184,37 @@ ppr_amode (CMacroExpr pk macro as) %************************************************************************ \begin{code} +pp_bitmap_switch :: [BitSet] -> SDoc -> SDoc -> SDoc +pp_bitmap_switch ([ ]) small large = small +pp_bitmap_switch ([_ ]) small large = small +pp_bitmap_switch ([_,_]) small large = hcat + [ptext SLIT("BITMAP_SWITCH64"), lparen, small, comma, large, rparen] +pp_bitmap_switch (_ ) small large = large + +pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc +pp_liveness_switch (Liveness lbl mask) = pp_bitmap_switch mask + +pp_bitset :: BitSet -> SDoc +pp_bitset s + | i < -1 = int (i + 1) <> text "-1" + | otherwise = int i + where i = intBS s + +pp_bitmap :: [BitSet] -> SDoc +pp_bitmap [] = int 0 +pp_bitmap ss = hcat (punctuate delayed_comma (bundle ss)) where + delayed_comma = hcat [space, ptext SLIT("COMMA"), space] + bundle [] = [] + bundle [s] = [hcat bitmap32] + where bitmap32 = [ptext SLIT("BITMAP32"), lparen, + pp_bitset s, rparen] + bundle (s1:s2:ss) = hcat bitmap64 : bundle ss + where bitmap64 = [ptext SLIT("BITMAP64"), lparen, + pp_bitset s1, comma, pp_bitset s2, rparen] + pp_liveness :: Liveness -> SDoc -pp_liveness lv = - case lv of - LvSmall mask -> int (intBS mask) - LvLarge lbl -> char '&' <> pprCLabel lbl +pp_liveness (Liveness lbl mask) + = pp_bitmap_switch mask (pp_bitmap mask) (char '&' <> pprCLabel lbl) \end{code} %************************************************************************ @@ -1201,6 +1261,11 @@ pprRegRelative sign_wanted (NodeRel o) else (pp_Node, Just (addPlusSign sign_wanted (int off))) +pprRegRelative sign_wanted (CIndex base offset kind) + = ( hcat [text "((", pprPrimKind kind, text " *)(", ppr_amode base, text "))"] + , Just (hcat [if sign_wanted then char '+' else empty, + text "(I_)(", ppr_amode offset, ptext SLIT(")")]) + ) \end{code} @pprMagicId@ just prints the register name. @VanillaReg@ registers are @@ -1214,9 +1279,9 @@ pprMagicId BaseReg = ptext SLIT("BaseReg") pprMagicId (VanillaReg pk n) = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId (FloatReg n) = (<>) (ptext SLIT("F")) (int IBOX(n)) -pprMagicId (DoubleReg n) = (<>) (ptext SLIT("D")) (int IBOX(n)) -pprMagicId (LongReg _ n) = (<>) (ptext SLIT("L")) (int IBOX(n)) +pprMagicId (FloatReg n) = ptext SLIT("F") <> int (I# n) +pprMagicId (DoubleReg n) = ptext SLIT("D") <> int (I# n) +pprMagicId (LongReg _ n) = ptext SLIT("L") <> int (I# n) pprMagicId Sp = ptext SLIT("Sp") pprMagicId Su = ptext SLIT("Su") pprMagicId SpLim = ptext SLIT("SpLim") @@ -1225,8 +1290,8 @@ pprMagicId HpLim = ptext SLIT("HpLim") pprMagicId CurCostCentre = ptext SLIT("CCCS") pprMagicId VoidReg = panic "pprMagicId:VoidReg!" -pprVanillaReg :: FAST_INT -> SDoc -pprVanillaReg n = (<>) (char 'R') (int IBOX(n)) +pprVanillaReg :: Int# -> SDoc +pprVanillaReg n = char 'R' <> int (I# n) pprUnionTag :: PrimRep -> SDoc @@ -1237,21 +1302,26 @@ pprUnionTag RetRep = char 'p' pprUnionTag CostCentreRep = panic "pprUnionTag:CostCentre?" pprUnionTag CharRep = char 'c' +pprUnionTag Int8Rep = ptext SLIT("i8") pprUnionTag IntRep = char 'i' pprUnionTag WordRep = char 'w' +pprUnionTag Int32Rep = char 'i' +pprUnionTag Word32Rep = char 'w' pprUnionTag AddrRep = char 'a' pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" -pprUnionTag StablePtrRep = char 'i' +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} @@ -1352,11 +1422,11 @@ tempSeenTE uniq env@(seen_uniqs, seen_labels) False) labelSeenTE :: CLabel -> TeM Bool -labelSeenTE label env@(seen_uniqs, seen_labels) - = if (label `elementOfCLabelSet` seen_labels) +labelSeenTE lbl env@(seen_uniqs, seen_labels) + = if (lbl `elementOfCLabelSet` seen_labels) then (env, True) else ((seen_uniqs, - addToCLabelSet seen_labels label), + addToCLabelSet seen_labels lbl), False) \end{code} @@ -1365,14 +1435,17 @@ pprTempDecl :: Unique -> PrimRep -> SDoc pprTempDecl uniq kind = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ] -pprExternDecl :: CLabel -> PrimRep -> SDoc +pprExternDecl :: Bool -> CLabel -> SDoc +pprExternDecl in_srt clabel + | not (needsCDecl clabel) = empty -- do not print anything for "known external" things + | otherwise = + hcat [ ppLocalnessMacro (not in_srt) clabel, + lparen, dyn_wrapper (pprCLabel clabel), pp_paren_semi ] + where + dyn_wrapper d + | in_srt && labelDynamic clabel = text "DLL_IMPORT_DATA_VAR" <> parens d + | otherwise = d -pprExternDecl clabel kind - = if not (needsCDecl clabel) then - empty -- do not print anything for "known external" things - else - hcat [ ppLocalnessMacro clabel, - lparen, pprCLabel clabel, pp_paren_semi ] \end{code} \begin{code} @@ -1406,22 +1479,22 @@ ppr_decls_AbsC (CSwitch discrim alts deflt) where ppr_alt_stuff (_, absC) = ppr_decls_AbsC absC -ppr_decls_AbsC (CCodeBlock label absC) +ppr_decls_AbsC (CCodeBlock lbl absC) = ppr_decls_AbsC absC -ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre) +ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _) -- ToDo: strictly speaking, should chk "cost_centre" amode = labelSeenTE info_lbl `thenTE` \ label_seen -> returnTE (Nothing, if label_seen then Nothing else - Just (pprExternDecl info_lbl PtrRep)) + Just (pprExternDecl False{-not in an SRT decl-} info_lbl)) where info_lbl = infoTableLabelFromCI cl_info ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args) -ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc +ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc ppr_decls_AbsC (CCheck _ amodes code) = ppr_decls_Amodes amodes `thenTE` \p1 -> @@ -1440,7 +1513,7 @@ ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes) -- ToDo: strictly speaking, should chk "cost_centre" amode = ppr_decls_Amodes amodes -ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _) +ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _) = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 -> ppr_decls_AbsC slow `thenTE` \ p2 -> (case maybe_fast of @@ -1453,32 +1526,34 @@ ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _) Nothing -> mkErrorStdEntryLabel Just _ -> entryLabelFromCI cl_info -ppr_decls_AbsC (CSRT lbl closure_lbls) +ppr_decls_AbsC (CSRT _ closure_lbls) = mapTE labelSeenTE closure_lbls `thenTE` \ seen -> returnTE (Nothing, if and seen then Nothing - else Just (vcat [ pprExternDecl l PtrRep + else Just (vcat [ pprExternDecl True{-in SRT decl-} l | (l,False) <- zip closure_lbls seen ])) 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 (_) = returnTE (Nothing, Nothing) \end{code} \begin{code} ppr_decls_Amode :: CAddrMode -> TeM (Maybe SDoc, Maybe SDoc) +ppr_decls_Amode (CVal (CIndex base offset _) _) = ppr_decls_Amodes [base,offset] +ppr_decls_Amode (CAddr (CIndex base offset _)) = ppr_decls_Amodes [base,offset] ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CReg _) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CString _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CLit _) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CLitLit _ _) = returnTE (Nothing, Nothing) -- CIntLike must be a literal -- no decls ppr_decls_Amode (CIntLike int) = returnTE (Nothing, Nothing) --- CCharLike may have be arbitrary value -- may have decls -ppr_decls_Amode (CCharLike char) - = ppr_decls_Amode char +-- CCharLike too +ppr_decls_Amode (CCharLike char) = returnTE (Nothing, Nothing) -- now, the only place where we actually print temps/externs... ppr_decls_Amode (CTemp uniq kind) @@ -1489,18 +1564,13 @@ ppr_decls_Amode (CTemp uniq kind) returnTE (if temp_seen then Nothing else Just (pprTempDecl uniq kind), Nothing) -ppr_decls_Amode (CLbl label VoidRep) +ppr_decls_Amode (CLbl lbl VoidRep) = returnTE (Nothing, Nothing) -ppr_decls_Amode (CLbl label kind) - = labelSeenTE label `thenTE` \ label_seen -> +ppr_decls_Amode (CLbl lbl kind) + = labelSeenTE lbl `thenTE` \ label_seen -> returnTE (Nothing, - if label_seen then Nothing else Just (pprExternDecl label kind)) - -ppr_decls_Amode (CTableEntry base index _) - = ppr_decls_Amode base `thenTE` \ p1 -> - ppr_decls_Amode index `thenTE` \ p2 -> - returnTE (maybe_vcat [p1, p2]) + if label_seen then Nothing else Just (pprExternDecl False{-not in an SRT decl-} lbl)) ppr_decls_Amode (CMacroExpr _ _ amodes) = ppr_decls_Amodes amodes @@ -1542,6 +1612,7 @@ pprCLabelAddr clabel = where addr_of_label = ptext SLIT("(P_)&") <> pp_label pp_label = pprCLabel clabel + \end{code} ----------------------------------------------------------------------------- @@ -1559,29 +1630,29 @@ big_doubles = (getPrimRepSize DoubleRep) /= 1 floatToWord :: CAddrMode -> CAddrMode floatToWord (CLit (MachFloat r)) = runST (do - arr <- newFloatArray (0,0) + arr <- newFloatArray ((0::Int),0) writeFloatArray arr 0 (fromRational r) i <- readIntArray arr 0 - return (CLit (MachInt (toInteger i) True)) + return (CLit (MachInt (toInteger i))) ) doubleToWords :: CAddrMode -> [CAddrMode] doubleToWords (CLit (MachDouble r)) | big_doubles -- doubles are 2 words = runST (do - arr <- newDoubleArray (0,1) + arr <- newDoubleArray ((0::Int),1) writeDoubleArray arr 0 (fromRational r) i1 <- readIntArray arr 0 i2 <- readIntArray arr 1 - return [ CLit (MachInt (toInteger i1) True) - , CLit (MachInt (toInteger i2) True) + return [ CLit (MachInt (toInteger i1)) + , CLit (MachInt (toInteger i2)) ] ) | otherwise -- doubles are 1 word = runST (do - arr <- newDoubleArray (0,0) + arr <- newDoubleArray ((0::Int),0) writeDoubleArray arr 0 (fromRational r) i <- readIntArray arr 0 - return [ CLit (MachInt (toInteger i) True) ] + return [ CLit (MachInt (toInteger i)) ] ) \end{code}