X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=f0ae17779fd930486f88a9d915cbd7c0648d3a7c;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=fe78a3d085b7d6aa3646c82352f79b642aa86332;hpb=64a906607f61efc8e31175bbafde463787eec402;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index fe78a3d..f0ae177 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -10,46 +10,65 @@ \begin{code} module PprAbsC ( writeRealC, - dumpRealC -#ifdef DEBUG - , pprAmode -- otherwise, not exported -#endif + dumpRealC, + pprAmode, + pprMagicId ) where #include "HsVersions.h" import IO ( Handle ) +import PrimRep import AbsCSyn import ClosureInfo import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import CallConv ( CallConv, callConvAttribute, cCallConv ) -import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE ) -import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, - isReadOnly, needsCDecl, pprCLabel, - CLabel{-instance Ord-} + +import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, + playThreadSafe, ccallConvAttribute, + ForeignCall(..), Safety(..), DNCallSpec(..), + DNType(..), DNKind(..) ) +import CLabel ( externallyVisibleCLabel, + needsCDecl, pprCLabel, mkClosureLabel, + mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, + CLabel, CLabelType(..), labelType, labelDynamic ) -import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros ) -import CostCentre ( uppCostCentre, uppCostCentreDecl ) + +import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) +import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl ) + import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) -import CStrings ( stringToC ) +import CStrings ( pprCLabelString ) import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) -import HeapOffs ( isZeroOff, subOff, pprHeapOffset ) -import Literal ( showLiteral, Literal(..) ) -import Maybes ( maybeToBool, catMaybes ) -import PrimOp ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) ) -import PrimRep ( isFloatingRep, PrimRep(..), showPrimRep ) -import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, - isConstantRep, isSpecRep, isPhantomRep - ) +import Literal ( Literal(..) ) +import TyCon ( tyConDataCons ) +import Name ( NamedThing(..) ) +import Maybes ( catMaybes ) +import PrimOp ( primOpNeedsWrapper ) +import MachOp ( MachOp(..) ) +import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, UniqSet ) +import StgSyn ( StgOp(..) ) import Outputable -import Util ( nOfThem, panic, assertPanic ) +import FastString +import Util ( lengthExceeds ) + +#if __GLASGOW_HASKELL__ >= 504 +import Data.Array.ST +#endif + +#ifdef DEBUG +import Util ( listLengthCmp ) +#endif + +import Maybe ( isJust ) +import GLAEXTS +import MONAD_ST infixr 9 `thenTE` \end{code} @@ -60,18 +79,34 @@ call to a cost evaluation function @GRAN_EXEC@. For that, @pprAbsC@ has a new ``costs'' argument. %% HWL \begin{code} -writeRealC :: Handle -> AbstractC -> SDoc -> IO () ---writeRealC handle absC postlude = +{- +writeRealC :: Handle -> AbstractC -> IO () +writeRealC handle absC + -- avoid holding on to the whole of absC in the !Gransim case. + if opt_GranMacros + then printForCFast fp (pprAbsC absC (costs absC)) + else printForCFast fp (pprAbsC absC (panic "costs")) + --printForC handle (pprAbsC absC (panic "costs")) +dumpRealC :: AbstractC -> SDoc +dumpRealC absC = pprAbsC absC (costs absC) +-} + +writeRealC :: Handle -> AbstractC -> IO () +--writeRealC handle absC = -- _scc_ "writeRealC" -- printDoc LeftMode handle (pprAbsC absC (costs absC)) -writeRealC handle absC postlude = - _scc_ "writeRealC" - printForC handle (pprAbsC absC (costs absC) $$ postlude) - -dumpRealC :: AbstractC -> SDoc -> SDoc -dumpRealC absC postlude - | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC) $$ postlude) - | otherwise = pprCode CStyle (pprAbsC absC (panic "costs") $$ postlude) + +writeRealC handle absC + | opt_GranMacros = _scc_ "writeRealC" printForC handle $ + pprCode CStyle (pprAbsC absC (costs absC)) + | otherwise = _scc_ "writeRealC" printForC handle $ + pprCode CStyle (pprAbsC absC (panic "costs")) + +dumpRealC :: AbstractC -> SDoc +dumpRealC absC + | opt_GranMacros = pprCode CStyle (pprAbsC absC (costs absC)) + | otherwise = pprCode CStyle (pprAbsC absC (panic "costs")) + \end{code} This emits the macro, which is used in GrAnSim to compute the total costs @@ -80,7 +115,8 @@ from a cost 5 tuple. %% HWL \begin{code} emitMacro :: CostRes -> SDoc --- ToDo: Check a compile time flag to decide whether a macro should be emitted +emitMacro _ | not opt_GranMacros = empty + emitMacro (Cost (i,b,l,s,f)) = hcat [ ptext SLIT("GRAN_EXEC"), char '(', int i, comma, int b, comma, int l, comma, @@ -98,10 +134,8 @@ pprAbsC :: AbstractC -> CostRes -> SDoc pprAbsC AbsCNop _ = empty pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c) -pprAbsC (CClosureUpdInfo info) c - = pprAbsC info c - pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src + pprAbsC (CJump target) c = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ]) (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) @@ -118,12 +152,14 @@ pprAbsC (CReturn am return_info) c (hcat [text jmp_lit, target, pp_paren_semi ]) where target = case return_info of - DirectReturn -> hcat [ptext SLIT("DIRECT"),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 [parens (pprAmode am), brackets (text "RVREL" <> parens x)] + 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. @@ -148,15 +184,16 @@ pprAbsC (CSwitch discrim [(tag,alt_code)] deflt) c -- only one alt Just dc -> -- make it an "if" do_if_stmt discrim tag alt_code dc c -pprAbsC (CSwitch discrim [(tag1@(MachInt i1 _), alt_code1), - (tag2@(MachInt i2 _), alt_code2)] deflt) 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 | empty_deflt && ((i1 == 0 && i2 == 1) || (i1 == 1 && i2 == 0)) = if (i1 == 0) then do_if_stmt discrim tag1 alt_code1 alt_code2 c else do_if_stmt discrim tag2 alt_code2 alt_code1 c where - empty_deflt = not (maybeToBool (nonemptyAbsC deflt)) + empty_deflt = not (isJust (nonemptyAbsC deflt)) pprAbsC (CSwitch discrim alts deflt) c -- general case | isFloatingRep (getAmodeRep discrim) @@ -185,10 +222,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 liveness_mask vol_regs) _ - = pprCCall op args results liveness_mask 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 liveness_mask 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 @@ -200,18 +237,18 @@ pprAbsC stmt@(COpStmt results op args liveness_mask 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)), @@ -221,222 +258,426 @@ pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _ -- primop macros do their own casting of result; -- hence we can toss the provided cast... +-- NEW CASES FOR EXPANDED PRIMOPS + +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 $$ + hcat ( + [ppr_amode res, equals] + ++ (if prefix_fn + then [pprMachOp_for_C mop, parens (pprAmode arg1 <> comma <> pprAmode arg2)] + else [pprAmode arg1, pprMachOp_for_C mop, pprAmode arg2]) + ++ [semi] + ) + $$ restores + } + +pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _ + = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> + saves $$ + hcat [ppr_amode res, equals, + pprMachOp_for_C mop, parens (pprAmode arg1), + semi] + $$ restores + } + +pprAbsC stmt@(CSequential stuff) c + = vcat (map (flip pprAbsC c) stuff) + +-- end of NEW CASES FOR EXPANDED PRIMOPS + +pprAbsC stmt@(CSRT lbl closures) c + = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> + pp_exts + $$ ptext SLIT("SRT") <> lparen <> pprCLabel lbl <> rparen + $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures))) + <> ptext SLIT("};") + } + +pprAbsC stmt@(CBitmap liveness@(Liveness lbl size mask)) c + = pprWordArray lbl (mkWordCLit (fromIntegral size) : bitmapAddrModes mask) + +pprAbsC stmt@(CSRTDesc desc_lbl srt_lbl off len bitmap) c + = pprWordArray desc_lbl ( + CAddr (CIndex (CLbl srt_lbl DataPtrRep) (mkIntCLit off) WordRep) : + mkWordCLit (fromIntegral len) : + bitmapAddrModes bitmap + ) + pprAbsC (CSimultaneous abs_c) c = hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")] -pprAbsC stmt@(CMacroStmt macro as) _ - = hcat [text (show macro), lparen, +pprAbsC (CCheck macro as code) c + = hcat [ptext (cCheckMacroText macro), lparen, + hcat (punctuate comma (map ppr_amode as)), comma, + pprAbsC code c, pp_paren_semi + ] +pprAbsC (CMacroStmt macro as) _ + = hcat [ptext (cStmtMacroText macro), lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting -pprAbsC stmt@(CCallProfCtrMacro op as) _ - = hcat [ptext op, lparen, +pprAbsC (CCallProfCtrMacro op as) _ + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC stmt@(CCallProfCCMacro op as) _ - = hcat [ptext op, lparen, +pprAbsC (CCallProfCCMacro op as) _ + = 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")) + , ccall_res_ty + , fun_nm + , parens (hsep (punctuate comma ccall_decl_ty_args)) + ] <> semi + where + {- + 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. + + -} -pprAbsC (CCodeBlock label abs_C) _ - = ASSERT( maybeToBool(nonemptyAbsC abs_C) ) + 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 + DynamicTarget -> ptext SLIT("_ccall_fun_ty") <> ppr uniq + StaticTarget x -> pprCLabelString x + + ccall_res_ty = + case non_void_results of + [] -> ptext SLIT("void") + [amode] -> ppr (getAmodeRep amode) + _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty" + + 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 = 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 (listLengthCmp nvrs 1 /= GT) nvrs + +pprAbsC (CCodeBlock lbl abs_C) _ + = if not (isJust(nonemptyAbsC abs_C)) then + 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 ") {"], + else "IF_("), + 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 inplace_upd) _ - = hcat [ pp_init_hdr, text "_HDR(", - ppr_amode (CAddr reg_rel), comma, - pprCLabel info_lbl, comma, + +pprAbsC (CInitHdr cl_info amode cost_centre size) _ + = hcat [ ptext SLIT("SET_HDR_"), char '(', + ppr_amode amode, comma, + pprCLabelAddr info_lbl, comma, if_profiling (pprAmode cost_centre), comma, - pprHeapOffset size, comma, int ptr_wds, pp_paren_semi ] + if_profiling (int size), + pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info - sm_rep = closureSMRep cl_info - size = closureSizeWithoutFixedHdr cl_info - ptr_wds = closurePtrsSize cl_info - pp_init_hdr = text (if inplace_upd then - getSMUpdInplaceHdrStr sm_rep - else - getSMInitHdrStr sm_rep) pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ pp_exts, hcat [ - ptext SLIT("SET_STATIC_HDR"),char '(', - pprCLabel closure_lbl, comma, + ptext SLIT("SET_STATIC_HDR"), char '(', + pprCLabel closure_lbl, comma, pprCLabel info_lbl, comma, - if_profiling (pprAmode cost_centre), comma, + if_profiling (pprAmode cost_centre), comma, ppLocalness closure_lbl, comma, - ppLocalnessMacro False{-for data-} info_lbl, + ppLocalnessMacro True{-include dyn-} info_lbl, char ')' ], - nest 2 (hcat (map ppr_item amodes)), - nest 2 (hcat (map ppr_item padding_wds)), + nest 2 (ppr_payload amodes), ptext SLIT("};") ] } where - info_lbl = infoTableLabelFromCI cl_info - - ppr_item item - = if getAmodeRep item == VoidRep - then text ", (W_) 0" -- might not even need this... - else (<>) (text ", (W_)") (ppr_amode item) - - padding_wds = - if not (closureUpdReqd cl_info) then - [] - else - case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed -> - nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s - -{- - STATIC_INIT_HDR(c,i,localness) blows into: - localness W_ c_closure [] = { i_info, extra_fixed_wd<1..n> - - then *NO VarHdr STUFF FOR STATIC*... + info_lbl = infoTableLabelFromCI cl_info + + ppr_payload [] = empty + 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 + +pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _ + = pprWordArray info_lbl (mkInfoTable cl_info) + $$ let stuff = CCodeBlock entry_lbl entry in + pprAbsC stuff (costs stuff) + where + entry_lbl = entryLabelFromCI cl_info + info_lbl = infoTableLabelFromCI cl_info + +pprAbsC stmt@(CClosureTbl tycon) _ + = vcat ( + ptext SLIT("CLOSURE_TBL") <> + lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen : + punctuate comma ( + map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon) + ) + ) $$ ptext SLIT("};") + +pprAbsC stmt@(CRetDirect uniq code srt liveness) _ + = pprWordArray info_lbl (mkRetInfoTable entry_lbl srt liveness) + $$ let stuff = CCodeBlock entry_lbl code in + pprAbsC stuff (costs stuff) + where + info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq - then the amodes are dropped in... - ,a1 ,a2 ... ,aN - then a close brace: - }; --} +pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ + = pprWordArray lbl (mkVecInfoTable amodes srt liveness) -pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _ +pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _ = vcat [ - hcat [ - pp_info_rep, - ptext SLIT("_ITBL"),char '(', - pprCLabel info_lbl, comma, - - -- CONST_ITBL needs an extra label for - -- the static version of the object. - if isConstantRep sm_rep - then (<>) (pprCLabel (closureLabelFromCI cl_info)) comma - else empty, - - pprCLabel slow_lbl, comma, - pprAmode upd, comma, - int liveness, comma, - - pp_tag, comma, - pp_size, comma, - pp_ptr_wds, comma, - - ppLocalness info_lbl, comma, - ppLocalnessMacro True{-function-} slow_lbl, comma, - - if is_selector - then (<>) (int select_word_i) comma - else empty, - - if_profiling pp_kind, comma, - if_profiling pp_descr, comma, - if_profiling pp_type, - text ");" - ], - pp_slow, - case maybe_fast of - Nothing -> empty - Just fast -> let stuff = CCodeBlock fast_lbl fast in - pprAbsC stuff (costs stuff) + 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 - info_lbl = infoTableLabelFromCI cl_info - fast_lbl = fastLabelFromCI cl_info - sm_rep = closureSMRep cl_info - - (slow_lbl, pp_slow) - = case (nonemptyAbsC slow) of - Nothing -> (mkErrorStdEntryLabel, empty) - Just xx -> (entryLabelFromCI cl_info, - let stuff = CCodeBlock slow_lbl xx in - pprAbsC stuff (costs stuff)) - - maybe_selector = maybeSelectorInfo cl_info - is_selector = maybeToBool maybe_selector - (Just (_, select_word_i)) = maybe_selector - pp_info_rep -- special stuff if it's a selector; otherwise, just the SMrep - = text (if is_selector then "SELECT" else (getSMInfoStr sm_rep)) - - pp_tag = int (closureSemiTag cl_info) +pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc +pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs +\end{code} - is_phantom = isPhantomRep sm_rep +Info tables... just arrays of words (the translation is done in +ClosureInfo). - pp_size = if isSpecRep sm_rep then -- exploiting: SPEC_VHS == 0 (always) - int (closureNonHdrSize cl_info) +\begin{code} +pprWordArray lbl amodes + = (case snd (initTE (ppr_decls_Amodes amodes)) of + Just pp -> pp + Nothing -> empty) + $$ hcat [ ppLocalness lbl, ptext SLIT("StgWord "), + pprCLabel lbl, ptext SLIT("[] = {") ] + $$ hcat (punctuate comma (map (castToWord.pprAmode) amodes)) + $$ ptext SLIT("};") + +castToWord s = text "(W_)(" <> s <> char ')' +\end{code} - else if is_phantom then -- do not have sizes for these - empty - else - pprHeapOffset (closureSizeWithoutFixedHdr cl_info) - - pp_ptr_wds = if is_phantom then - empty - else - int (closurePtrsSize cl_info) - - pp_kind = text (closureKind cl_info) - pp_descr = hcat [char '"', text (stringToC cl_descr), char '"'] - pp_type = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"'] - -pprAbsC (CRetVector lbl maybes deflt) c - = vcat [ ptext SLIT("{ // CRetVector (lbl????)"), - nest 8 (sep (map ppr_maybe_amode maybes)), - text "} /*default=*/ {", pprAbsC deflt c, - char '}'] +\begin{code} +-- Print a CMachOp in a way suitable for emitting via C. +pprMachOp_for_C MO_Nat_Add = char '+' +pprMachOp_for_C MO_Nat_Sub = char '-' +pprMachOp_for_C MO_Nat_Eq = text "==" +pprMachOp_for_C MO_Nat_Ne = text "!=" + +pprMachOp_for_C MO_NatS_Ge = text ">=" +pprMachOp_for_C MO_NatS_Le = text "<=" +pprMachOp_for_C MO_NatS_Gt = text ">" +pprMachOp_for_C MO_NatS_Lt = text "<" + +pprMachOp_for_C MO_NatU_Ge = text ">=" +pprMachOp_for_C MO_NatU_Le = text "<=" +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 '-' + +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_Nat_And = text "&" +pprMachOp_for_C MO_Nat_Or = text "|" +pprMachOp_for_C MO_Nat_Xor = text "^" +pprMachOp_for_C MO_Nat_Not = text "~" +pprMachOp_for_C MO_Nat_Shl = text "<<" +pprMachOp_for_C MO_Nat_Shr = text ">>" +pprMachOp_for_C MO_Nat_Sar = text ">>" + +pprMachOp_for_C MO_32U_Eq = text "==" +pprMachOp_for_C MO_32U_Ne = text "!=" +pprMachOp_for_C MO_32U_Ge = text ">=" +pprMachOp_for_C MO_32U_Le = text "<=" +pprMachOp_for_C MO_32U_Gt = text ">" +pprMachOp_for_C MO_32U_Lt = text "<" + +pprMachOp_for_C MO_Dbl_Eq = text "==" +pprMachOp_for_C MO_Dbl_Ne = text "!=" +pprMachOp_for_C MO_Dbl_Ge = text ">=" +pprMachOp_for_C MO_Dbl_Le = text "<=" +pprMachOp_for_C MO_Dbl_Gt = text ">" +pprMachOp_for_C MO_Dbl_Lt = text "<" + +pprMachOp_for_C MO_Dbl_Add = text "+" +pprMachOp_for_C MO_Dbl_Sub = text "-" +pprMachOp_for_C MO_Dbl_Mul = text "*" +pprMachOp_for_C MO_Dbl_Div = text "/" +pprMachOp_for_C MO_Dbl_Pwr = text "pow" + +pprMachOp_for_C MO_Dbl_Sin = text "sin" +pprMachOp_for_C MO_Dbl_Cos = text "cos" +pprMachOp_for_C MO_Dbl_Tan = text "tan" +pprMachOp_for_C MO_Dbl_Sinh = text "sinh" +pprMachOp_for_C MO_Dbl_Cosh = text "cosh" +pprMachOp_for_C MO_Dbl_Tanh = text "tanh" +pprMachOp_for_C MO_Dbl_Asin = text "asin" +pprMachOp_for_C MO_Dbl_Acos = text "acos" +pprMachOp_for_C MO_Dbl_Atan = text "atan" +pprMachOp_for_C MO_Dbl_Log = text "log" +pprMachOp_for_C MO_Dbl_Exp = text "exp" +pprMachOp_for_C MO_Dbl_Sqrt = text "sqrt" +pprMachOp_for_C MO_Dbl_Neg = text "-" + +pprMachOp_for_C MO_Flt_Add = text "+" +pprMachOp_for_C MO_Flt_Sub = text "-" +pprMachOp_for_C MO_Flt_Mul = text "*" +pprMachOp_for_C MO_Flt_Div = text "/" +pprMachOp_for_C MO_Flt_Pwr = text "pow" + +pprMachOp_for_C MO_Flt_Eq = text "==" +pprMachOp_for_C MO_Flt_Ne = text "!=" +pprMachOp_for_C MO_Flt_Ge = text ">=" +pprMachOp_for_C MO_Flt_Le = text "<=" +pprMachOp_for_C MO_Flt_Gt = text ">" +pprMachOp_for_C MO_Flt_Lt = text "<" + +pprMachOp_for_C MO_Flt_Sin = text "sin" +pprMachOp_for_C MO_Flt_Cos = text "cos" +pprMachOp_for_C MO_Flt_Tan = text "tan" +pprMachOp_for_C MO_Flt_Sinh = text "sinh" +pprMachOp_for_C MO_Flt_Cosh = text "cosh" +pprMachOp_for_C MO_Flt_Tanh = text "tanh" +pprMachOp_for_C MO_Flt_Asin = text "asin" +pprMachOp_for_C MO_Flt_Acos = text "acos" +pprMachOp_for_C MO_Flt_Atan = text "atan" +pprMachOp_for_C MO_Flt_Log = text "log" +pprMachOp_for_C MO_Flt_Exp = text "exp" +pprMachOp_for_C MO_Flt_Sqrt = text "sqrt" +pprMachOp_for_C MO_Flt_Neg = text "-" + +pprMachOp_for_C MO_32U_to_NatS = text "(StgInt)" +pprMachOp_for_C MO_NatS_to_32U = text "(StgWord32)" + +pprMachOp_for_C MO_NatS_to_Dbl = text "(StgDouble)" +pprMachOp_for_C MO_Dbl_to_NatS = text "(StgInt)" + +pprMachOp_for_C MO_NatS_to_Flt = text "(StgFloat)" +pprMachOp_for_C MO_Flt_to_NatS = text "(StgInt)" + +pprMachOp_for_C MO_NatS_to_NatU = text "(StgWord)" +pprMachOp_for_C MO_NatU_to_NatS = text "(StgInt)" + +pprMachOp_for_C MO_NatS_to_NatP = text "(void*)" +pprMachOp_for_C MO_NatP_to_NatS = text "(StgInt)" +pprMachOp_for_C MO_NatU_to_NatP = text "(void*)" +pprMachOp_for_C MO_NatP_to_NatU = text "(StgWord)" + +pprMachOp_for_C MO_Dbl_to_Flt = text "(StgFloat)" +pprMachOp_for_C MO_Flt_to_Dbl = text "(StgDouble)" + +pprMachOp_for_C MO_8S_to_NatS = text "(StgInt8)(StgInt)" +pprMachOp_for_C MO_16S_to_NatS = text "(StgInt16)(StgInt)" +pprMachOp_for_C MO_32S_to_NatS = text "(StgInt32)(StgInt)" + +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_8U_to_32U = text "(StgWord32)" +pprMachOp_for_C MO_32U_to_8U = text "(StgWord8)" + + +ppLocalness lbl + = if (externallyVisibleCLabel lbl) + then empty + else ptext SLIT("static ") + +-- Horrible macros for declaring the types and locality of labels (see +-- StgMacros.h). + +ppLocalnessMacro include_dyn_prefix clabel = + hcat [ + visiblity_prefix, + dyn_prefix, + case label_type of + ClosureType -> ptext SLIT("C_") + CodeType -> ptext SLIT("F_") + InfoTblType -> ptext SLIT("I_") + RetInfoTblType -> ptext SLIT("RI_") + ClosureTblType -> ptext SLIT("CP_") + DataType -> ptext SLIT("D_") + ] where - ppr_maybe_amode Nothing = ptext SLIT("/*default*/") - ppr_maybe_amode (Just a) = pprAmode a + is_visible = externallyVisibleCLabel clabel + label_type = labelType clabel -pprAbsC stmt@(CRetUnVector label amode) _ - = hcat [ptext SLIT("UNVECTBL"),char '(', pp_static, comma, pprCLabel label, comma, - pprAmode amode, rparen] - where - pp_static = if externallyVisibleCLabel label then empty else ptext SLIT("static") - -pprAbsC stmt@(CFlatRetVector label amodes) _ - = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - vcat [ - pp_exts, - hcat [ppLocalness label, ptext SLIT(" W_ "), - pprCLabel label, text "[] = {"], - nest 2 (sep (punctuate comma (map ppr_item amodes))), - text "};" ] } - where - ppr_item item = (<>) (text "(W_) ") (ppr_amode item) + visiblity_prefix + | is_visible = char 'E' + | otherwise = char 'I' -pprAbsC (CCostCentreDecl is_local cc) _ = uppCostCentreDecl is_local cc -\end{code} + dyn_prefix + | include_dyn_prefix && labelDynamic clabel = char 'D' + | otherwise = empty -\begin{code} -ppLocalness label - = (<>) static const - where - static = if (externallyVisibleCLabel label) then empty else ptext SLIT("static ") - const = if not (isReadOnly label) then empty else ptext SLIT("const") - -ppLocalnessMacro for_fun{-vs data-} clabel - = hcat [ char (if externallyVisibleCLabel clabel then 'E' else 'I'), - if for_fun then - ptext SLIT("F_") - else - (<>) (ptext SLIT("D_")) - (if isReadOnly clabel then - ptext SLIT("RO_") - else - empty)] \end{code} \begin{code} @@ -452,6 +693,15 @@ non_void amode \end{code} \begin{code} +ppr_maybe_vol_regs :: Maybe [MagicId] -> (SDoc, SDoc) +ppr_maybe_vol_regs Nothing + = (empty, empty) +ppr_maybe_vol_regs (Just vrs) + = case ppr_vol_regs vrs of + (saves, restores) + -> (pp_basic_saves $$ saves, + pp_basic_restores $$ restores) + ppr_vol_regs :: [MagicId] -> (SDoc, SDoc) ppr_vol_regs [] = (empty, empty) @@ -465,36 +715,20 @@ 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, 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. -pp_basic_saves - = vcat [ - ptext SLIT("CALLER_SAVE_Base"), - ptext SLIT("CALLER_SAVE_SpA"), - ptext SLIT("CALLER_SAVE_SuA"), - ptext SLIT("CALLER_SAVE_SpB"), - ptext SLIT("CALLER_SAVE_SuB"), - ptext SLIT("CALLER_SAVE_Ret"), --- ptext SLIT("CALLER_SAVE_Activity"), - ptext SLIT("CALLER_SAVE_Hp"), - ptext SLIT("CALLER_SAVE_HpLim") ] - -pp_basic_restores - = vcat [ - ptext SLIT("CALLER_RESTORE_Base"), -- must be first! - ptext SLIT("CALLER_RESTORE_SpA"), - ptext SLIT("CALLER_RESTORE_SuA"), - ptext SLIT("CALLER_RESTORE_SpB"), - ptext SLIT("CALLER_RESTORE_SuB"), - ptext SLIT("CALLER_RESTORE_Ret"), --- ptext SLIT("CALLER_RESTORE_Activity"), - ptext SLIT("CALLER_RESTORE_Hp"), - ptext SLIT("CALLER_RESTORE_HpLim"), - ptext SLIT("CALLER_RESTORE_StdUpdRetVec"), - ptext SLIT("CALLER_RESTORE_StkStub") ] +-- anything else. The correct sequence of saves&restores are +-- encoded by the CALLER_*_SYSTEM macros. +pp_basic_saves = ptext SLIT("CALLER_SAVE_SYSTEM") +pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") +\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} @@ -510,20 +744,27 @@ if_profiling pretty -- --------------------------------------------------------------------------- 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) - deflt alt_code - (addrModeCosts discrim Rhs) c - other -> let - cond = hcat [ pprAmode discrim, - ptext SLIT(" == "), - pprAmode (CLit tag) ] - in - ppr_if_stmt cond - alt_code deflt - (addrModeCosts discrim Rhs) c + = let + cond = hcat [ pprAmode discrim + , ptext SLIT(" == ") + , tcast + , pprAmode (CLit tag) + ] + -- to be absolutely sure that none of the + -- conversion rules hit, e.g., + -- + -- minInt is different to (int)minInt + -- + -- in C (when minInt is a number not a constant + -- expression which evaluates to it.) + -- + tcast = case tag of + MachInt _ -> ptext SLIT("(I_)") + _ -> empty + in + ppr_if_stmt cond + alt_code deflt + (addrModeCosts discrim Rhs) c ppr_if_stmt pp_pred then_part else_part discrim_costs c = vcat [ @@ -564,11 +805,6 @@ Some rough notes on generating code for @CCallOp@: (This happens after restoration of essential registers because we might need the @Base@ register to access all the others correctly.) -{- Doesn't apply anymore with ForeignObj, structure created via the primop. - makeForeignObj (i.e., ForeignObj is not CReturnable) -7) If returning Malloc Pointer, build a closure containing the - appropriate value. --} Otherwise, copy local variable into result register. 8) If ccall (not casm), declare the function being called as extern so @@ -592,133 +828,137 @@ Amendment to the above: if we can GC, we have to: can get at them. * be sure that there are no live registers or we're in trouble. (This can cause problems if you try something foolish like passing - an array or foreign obj to a _ccall_GC_ thing.) + an array or a foreign obj to a _ccall_GC_ thing.) * increment/decrement the @inCCallGC@ counter before/after the call so 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 liveness_mask vol_regs - = if (may_gc && liveness_mask /= noLiveRegsMask) - then pprPanic "Live register in _casm_GC_ " - (doubleQuotes (text casm_str) <+> hsep pp_non_void_args) - else - vcat [ - char '{', - declare_fun_extern, -- declare expected function type. - declare_local_vars, -- local var for *result* - vcat local_arg_decls, - pp_save_context, - process_casm local_vars pp_non_void_args casm_str, - pp_restore_context, - assign_results, - char '}' - ] +pprFCall call uniq args results vol_regs + = case call of + CCall (CCallSpec target _cconv safety) -> + vcat [ char '{', + declare_local_vars, -- local var for *result* + vcat local_arg_decls, + makeCall target safety + (process_casm local_vars pp_non_void_args (call_str target)), + assign_results, + char '}' + ] + DNCall (DNCallSpec isStatic kind assem nm argTys resTy) -> + let + target = StaticTarget (mkFastString nm) + resultVar = "_ccall_result" + + hasAssemArg = isStatic || kind == DNConstructor + invokeOp = + case kind of + DNMethod + | isStatic -> "DN_invokeStatic" + | otherwise -> "DN_invokeMethod" + DNField + | isStatic -> + if resTy == DNUnit + then "DN_setStatic" + else "DN_getStatic" + | otherwise -> + if resTy == DNUnit + then "DN_setField" + else "DN_getField" + DNConstructor -> "DN_createObject" + + (methArrDecl, methArrInit, methArrName, methArrLen) + | null argTys = (empty, empty, text "NULL", text "0") + | otherwise = + ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];" + , vcat (zipWith3 (\ idx arg argTy -> + text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$ + text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi) + [0..] + non_void_args + argTys) + , text "__meth_args" + , int (length non_void_args) + ) + in + vcat [ char '{', + declare_local_vars, + vcat local_arg_decls, + vcat [ methArrDecl + , methArrInit + , text "_ccall_result1 =" <+> text invokeOp <> parens ( + hcat (punctuate comma $ + (if hasAssemArg then + ((if null assem then + text "NULL" + else + doubleQuotes (text assem)):) + else + id) $ + [ doubleQuotes $ text nm + , methArrName + , methArrLen + , text (toDotnetTy resTy) + , text "(void*)&" <> text resultVar + ])) <> semi + ], + assign_results, + char '}' + ] where (pp_saves, pp_restores) = ppr_vol_regs vol_regs - - (pp_save_context, pp_restore_context) - | may_gc = - ( text "do { extern StgInt inCCallGC; SaveAllStgRegs(); inCCallGC++;" - , text "inCCallGC--; RestoreAllStgRegs();} while(0);" - ) - | 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) + + makeCall target safety theCall = + vcat [ pp_save_context, theCall, pp_restore_context ] + where + (pp_save_context, pp_restore_context) + | 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) + where + thread_macro_args = ppr_uniq_token <> comma <+> + text "rts" <> ppr (playThreadSafe safety) + ppr_uniq_token = text "tok_" <> ppr uniq + + + 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 (forDotnet || 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..] ] - pp_liveness = pprAmode (mkIntCLit liveness_mask) - - {- - 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_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") - (declare_local_vars, local_vars, assign_results) - = ppr_casm_results non_void_results pp_liveness + = ppr_casm_results non_void_results forDotnet - (Just asm_str) = op_str - is_dynamic = not (maybeToBool op_str) + forDotnet + = case call of + DNCall{} -> True + _ -> False - casm_str = if is_asm then _UNPK_ asm_str else ccall_str - - -- Remainder only used for ccall + call_str tgt + = case tgt of + CasmTarget str -> unpackFS str + StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args + DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) - fun_name - | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0") - | otherwise = ptext asm_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") + - ccall_str = showSDoc + -- Remainder only used for ccall + mk_ccall_str fun_name ccall_fun_args = showSDoc (hcat [ if null non_void_results then empty @@ -728,19 +968,50 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask 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 -the bit the C world wants to see. The only heap objects which can be -passed are @Array@s, @ByteArray@s and @ForeignObj@s. +toDotnetTy :: DNType -> String +toDotnetTy x = + case x of + DNByte -> "Dotnet_Byte" + DNBool -> "Dotnet_Bool" + DNChar -> "Dotnet_Char" + DNDouble -> "Dotnet_Double" + DNFloat -> "Dotnet_Float" + DNInt -> "Dotnet_Int" + DNInt8 -> "Dotnet_Int8" + DNInt16 -> "Dotnet_Int16" + DNInt32 -> "Dotnet_Int32" + DNInt64 -> "Dotnet_Int64" + DNWord8 -> "Dotnet_Word8" + DNWord16 -> "Dotnet_Word16" + DNWord32 -> "Dotnet_Word32" + DNWord64 -> "Dotnet_Word64" + DNPtr -> "Dotnet_Ptr" + DNUnit -> "Dotnet_Unit" + DNObject -> "Dotnet_Object" + DNString -> "Dotnet_String" + +toDotnetArgField :: DNType -> String +toDotnetArgField x = + case x of + DNByte -> "arg_byte" + DNBool -> "arg_bool" + DNChar -> "arg_char" + DNDouble -> "arg_double" + DNFloat -> "arg_float" + DNInt -> "arg_int" + DNInt8 -> "arg_int8" + DNInt16 -> "arg_int16" + DNInt32 -> "arg_int32" + DNInt64 -> "arg_int64" + DNWord8 -> "arg_word8" + DNWord16 -> "arg_word16" + DNWord32 -> "arg_word32" + DNWord64 -> "arg_word64" + DNPtr -> "arg_ptr" + DNUnit -> "arg_ptr" -- can't happen + DNObject -> "arg_obj" + DNString -> "arg_str" -\begin{code} ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc) -- (a) decl and assignment, (b) local var to be used later @@ -752,24 +1023,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 -> (ptext SLIT("StgForeignObj"), - 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} @@ -780,58 +1035,38 @@ For l-values, the critical questions are: We only allow zero or one results. -{- With the introduction of ForeignObj (MallocPtr++), no longer necess. -2) Is the result is a foreign obj? - - The mallocptr must be encapsulated immediately in a heap object. --} \begin{code} ppr_casm_results :: [CAddrMode] -- list of results (length <= 1) - -> SDoc -- liveness mask + -> Bool -- True => multiple results OK. -> ( SDoc, -- declaration of any local vars [SDoc], -- list of result vars (same length as results) SDoc ) -- assignment (if any) of results in local var to registers -ppr_casm_results [] liveness +ppr_casm_results [] _ = (empty, [], empty) -- no results -ppr_casm_results [r] liveness - = let +ppr_casm_results (r:rs) multiResultsOK + | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results" + | otherwise + = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs)) + (empty,[],empty) + (zipWith pprRes (r:rs) ("" : map show [(1::Int)..])) + where + pprRes r suf = (declare_local_var, [local_var], assign_result) + where result_reg = ppr_amode r r_kind = getAmodeRep r - local_var = ptext SLIT("_ccall_result") + local_var = ptext SLIT("_ccall_result") <> text suf (result_type, assign_result) - = case r_kind of -{- - @ForeignObj@s replaces MallocPtrs and are *not* CReturnable. - Instead, external references have to explicitly turned into ForeignObjs - using the primop makeForeignObj#. Benefit: Multiple finalisation - routines can be accommodated and the below special case is not needed. - Price is, of course, that you have to explicitly wrap `foreign objects' - with makeForeignObj#. - - ForeignObjRep -> - (ptext SLIT("StgForeignObj"), - hcat [ ptext SLIT("constructForeignObj"),char '(', - liveness, comma, - result_reg, comma, - local_var, - pp_paren_semi ]) --} - _ -> - (pprPrimKind r_kind, - hcat [ result_reg, equals, local_var, semi ]) + = (pprPrimKind r_kind, + hcat [ result_reg, equals, local_var, semi ]) declare_local_var = hcat [ result_type, space, local_var, semi ] - in - (declare_local_var, [local_var], assign_result) -ppr_casm_results rs liveness - = panic "ppr_casm_results: ccall/casm with many results" \end{code} @@ -850,7 +1085,9 @@ process_casm :: [SDoc] -- results (length <= 1) process_casm results args string = process results args string where process [] _ "" = empty - process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ string ++ "\"\n(Try changing result type to PrimIO ()\n") + process (_:_) _ "" = error ("process_casm: non-void result not assigned while processing _casm_ \"" ++ + string ++ + "\"\n(Try changing result type to IO ()\n") process ress args ('%':cs) = case cs of @@ -858,12 +1095,12 @@ process_casm results args string = process results args string error ("process_casm: lonely % while processing _casm_ \"" ++ string ++ "\".\n") ('%':css) -> - (<>) (char '%') (process ress args css) + char '%' <> process ress args css ('r':css) -> case ress of [] -> error ("process_casm: no result to match %r while processing _casm_ \"" ++ string ++ "\".\nTry deleting %r or changing result type from PrimIO ()\n") - [r] -> (<>) r (process [] args css) + [r] -> r <> (process [] args css) _ -> panic ("process_casm: casm with many results while processing _casm_ \"" ++ string ++ "\".\n") other -> @@ -873,14 +1110,13 @@ process_casm results args string = process results args string in case (read_int other) of [(num,css)] -> - if 0 <= num && num < length args - then (<>) (parens (args !! num)) - (process ress args css) - else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n") + 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") process ress args (other_c:cs) - = (<>) (char other_c) (process ress args cs) + = char other_c <> process ress args cs \end{code} %************************************************************************ @@ -906,27 +1142,27 @@ 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 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)) @@ -947,13 +1183,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 to StgPtr (a.k.a. B_) iff the source is mixed - = hcat [ ppr_amode dest, equals, - text "(B_)(", -- Here is the cast - ppr_amode src, pp_paren_semi ] - pprAssign kind other_dest src = hcat [ ppr_amode other_dest, equals, pprAmode src, semi ] @@ -983,13 +1212,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 @@ -1004,6 +1233,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} @@ -1015,53 +1267,78 @@ ppr_amode (CVal reg_rel _) ppr_amode (CAddr reg_rel) = case (pprRegRelative True{-sign wanted-} reg_rel) of (pp_reg, Nothing) -> pp_reg - (pp_reg, Just offset) -> (<>) pp_reg offset + (pp_reg, Just offset) -> pp_reg <> offset ppr_amode (CReg magic_id) = pprMagicId magic_id -ppr_amode (CTemp uniq kind) = pprUnique uniq <> char '_' +ppr_amode (CTemp uniq kind) = char '_' <> pprUnique uniq <> char '_' -ppr_amode (CLbl label kind) = pprCLabel label - -ppr_amode (CUnVecLbl direct vectored) - = hcat [char '(',ptext SLIT("StgRetAddr"),char ')', ptext SLIT("UNVEC"),char '(', pprCLabel direct, comma, - pprCLabel vectored, rparen] +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 (COffset off) = pprHeapOffset off - -ppr_amode (CCode abs_C) - = vcat [ ptext SLIT("{ -- CCode"), nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ] - -ppr_amode (CLabelledCode label abs_C) - = vcat [ hcat [pprCLabel label, ptext SLIT(" = { -- CLabelledCode")], - nest 8 (pprAbsC abs_C (costs abs_C)), char '}' ] - -ppr_amode (CJoinPoint _ _) +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) - = hcat [lparen, pprPrimKind pk, text ")(", text (show macro), lparen, - hcat (punctuate comma (map pprAmode as)), text "))"] + = 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") +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 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 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") +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_FUN = SLIT("HP_CHK_FUN") +cCheckMacroText STK_CHK_FUN = SLIT("STK_CHK_FUN") +cCheckMacroText HP_STK_CHK_FUN = SLIT("HP_STK_CHK_FUN") +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_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE") +\end{code} -ppr_amode (CCostCentre cc print_as_string) - = uppCostCentre print_as_string cc +%************************************************************************ +%* * +\subsection[ppr-liveness-masks]{Liveness Masks} +%* * +%************************************************************************ + +\begin{code} +bitmapAddrModes [] = [mkWordCLit 0] +bitmapAddrModes xs = map mkWordCLit xs \end{code} %************************************************************************ @@ -1089,31 +1366,30 @@ pprRegRelative :: Bool -- True <=> Print leading plus sign (if +ve) -> RegRelative -> (SDoc, Maybe SDoc) -pprRegRelative sign_wanted (SpARel spA off) - = (pprMagicId SpA, pprSignedInt sign_wanted (spARelToInt spA off)) +pprRegRelative sign_wanted (SpRel off) + = (pprMagicId Sp, pprSignedInt sign_wanted (I# off)) -pprRegRelative sign_wanted (SpBRel spB off) - = (pprMagicId SpB, pprSignedInt sign_wanted (spBRelToInt spB off)) - -pprRegRelative sign_wanted r@(HpRel hp off) - = let to_print = hp `subOff` off - pp_Hp = pprMagicId Hp +pprRegRelative sign_wanted r@(HpRel o) + = let pp_Hp = pprMagicId Hp; off = I# o in - if isZeroOff to_print then + if off == 0 then (pp_Hp, Nothing) else - (pp_Hp, Just ((<>) (char '-') (pprHeapOffset to_print))) - -- No parens needed because pprHeapOffset - -- does them when necessary + (pp_Hp, Just ((<>) (char '-') (int off))) -pprRegRelative sign_wanted (NodeRel off) - = let pp_Node = pprMagicId node +pprRegRelative sign_wanted (NodeRel o) + = let pp_Node = pprMagicId node; off = I# o in - if isZeroOff off then + if off == 0 then (pp_Node, Nothing) else - (pp_Node, Just (addPlusSign sign_wanted (pprHeapOffset off))) + (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 @@ -1124,51 +1400,41 @@ to select the union tag. pprMagicId :: MagicId -> SDoc pprMagicId BaseReg = ptext SLIT("BaseReg") -pprMagicId StkOReg = ptext SLIT("StkOReg") pprMagicId (VanillaReg pk n) = hcat [ pprVanillaReg n, char '.', pprUnionTag pk ] -pprMagicId (FloatReg n) = (<>) (ptext SLIT("FltReg")) (int IBOX(n)) -pprMagicId (DoubleReg n) = (<>) (ptext SLIT("DblReg")) (int IBOX(n)) -pprMagicId (LongReg _ n) = (<>) (ptext SLIT("LngReg")) (int IBOX(n)) -pprMagicId TagReg = ptext SLIT("TagReg") -pprMagicId RetReg = ptext SLIT("RetReg") -pprMagicId SpA = ptext SLIT("SpA") -pprMagicId SuA = ptext SLIT("SuA") -pprMagicId SpB = ptext SLIT("SpB") -pprMagicId SuB = ptext SLIT("SuB") -pprMagicId Hp = ptext SLIT("Hp") +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 SpLim = ptext SLIT("SpLim") +pprMagicId Hp = ptext SLIT("Hp") pprMagicId HpLim = ptext SLIT("HpLim") -pprMagicId LivenessReg = ptext SLIT("LivenessReg") -pprMagicId StdUpdRetVecReg = ptext SLIT("StdUpdRetVecReg") -pprMagicId StkStubReg = ptext SLIT("StkStubReg") -pprMagicId CurCostCentre = ptext SLIT("CCC") +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 pprUnionTag PtrRep = char 'p' pprUnionTag CodePtrRep = ptext SLIT("fp") pprUnionTag DataPtrRep = char 'd' -pprUnionTag RetRep = char 'r' +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 AddrRep = char 'v' +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 ForeignObjRep = char 'p' - -pprUnionTag ArrayRep = char 'p' -pprUnionTag ByteArrayRep = char 'b' +pprUnionTag StablePtrRep = char 'p' pprUnionTag _ = panic "pprUnionTag:Odd kind" \end{code} @@ -1269,33 +1535,30 @@ 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} \begin{code} pprTempDecl :: Unique -> PrimRep -> SDoc pprTempDecl uniq kind - = hcat [ pprPrimKind kind, space, pprUnique uniq, ptext SLIT("_;") ] - -pprExternDecl :: CLabel -> PrimRep -> SDoc - -pprExternDecl clabel kind - = if not (needsCDecl clabel) then - empty -- do not print anything for "known external" things (e.g., < PreludeCore) - else - case ( - case kind of - CodePtrRep -> ppLocalnessMacro True{-function-} clabel - _ -> ppLocalnessMacro False{-data-} clabel - ) of { pp_macro_str -> + = hcat [ pprPrimKind kind, space, char '_', pprUnique uniq, ptext SLIT("_;") ] + +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 - hcat [ pp_macro_str, lparen, pprCLabel clabel, pp_paren_semi ] - } \end{code} \begin{code} @@ -1308,9 +1571,6 @@ ppr_decls_AbsC (AbsCStmts stmts_1 stmts_2) ppr_decls_AbsC stmts_2 `thenTE` \ p2 -> returnTE (maybe_vcat [p1, p2]) -ppr_decls_AbsC (CClosureUpdInfo info) - = ppr_decls_AbsC info - ppr_decls_AbsC (CSplitMarker) = returnTE (Nothing, Nothing) ppr_decls_AbsC (CAssign dest source) @@ -1332,22 +1592,33 @@ 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 inplace_upd) +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 (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 + +ppr_decls_AbsC (CSequential abcs) + = mapTE ppr_decls_AbsC abcs `thenTE` \ t_and_e_s -> + returnTE (maybe_vcat t_and_e_s) + +ppr_decls_AbsC (CCheck _ amodes code) = + ppr_decls_Amodes amodes `thenTE` \p1 -> + ppr_decls_AbsC code `thenTE` \p2 -> + returnTE (maybe_vcat [p1,p2]) ppr_decls_AbsC (CMacroStmt _ amodes) = ppr_decls_Amodes amodes @@ -1357,48 +1628,45 @@ 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 -ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _) - = ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 -> - ppr_decls_AbsC slow `thenTE` \ p2 -> - (case maybe_fast of - Nothing -> returnTE (Nothing, Nothing) - Just fast -> ppr_decls_AbsC fast) `thenTE` \ p3 -> - returnTE (maybe_vcat [p1, p2, p3]) - where - entry_lbl = CLbl slow_lbl CodePtrRep - slow_lbl = case (nonemptyAbsC slow) of - Nothing -> mkErrorStdEntryLabel - Just _ -> entryLabelFromCI cl_info - -ppr_decls_AbsC (CRetVector label maybe_amodes absC) - = ppr_decls_Amodes (catMaybes maybe_amodes) `thenTE` \ p1 -> - ppr_decls_AbsC absC `thenTE` \ p2 -> +ppr_decls_AbsC (CClosureInfoAndCode cl_info entry) + = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 -> + ppr_decls_AbsC entry `thenTE` \ p2 -> returnTE (maybe_vcat [p1, p2]) + where + entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep + +ppr_decls_AbsC (CSRT _ closure_lbls) + = mapTE labelSeenTE closure_lbls `thenTE` \ seen -> + returnTE (Nothing, + if and seen then Nothing + else Just (vcat [ pprExternDecl True{-in SRT decl-} l + | (l,False) <- zip closure_lbls seen ])) -ppr_decls_AbsC (CRetUnVector _ amode) = ppr_decls_Amode amode -ppr_decls_AbsC (CFlatRetVector _ amodes) = ppr_decls_Amodes amodes +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) -ppr_decls_Amode (COffset _) = 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) @@ -1409,47 +1677,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)) - -{- WRONG: -ppr_decls_Amode (CUnVecLbl direct vectored) - = labelSeenTE direct `thenTE` \ dlbl_seen -> - labelSeenTE vectored `thenTE` \ vlbl_seen -> - let - ddcl = if dlbl_seen then empty else pprExternDecl direct CodePtrRep - vdcl = if vlbl_seen then empty else pprExternDecl vectored DataPtrRep - in - returnTE (Nothing, - if (dlbl_seen || not (needsCDecl direct)) && - (vlbl_seen || not (needsCDecl vectored)) then Nothing - else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen])) --} - -ppr_decls_Amode (CUnVecLbl direct vectored) - = -- We don't mark either label as "seen", because - -- we don't know which one will be used and which one tossed - -- by the C macro... - --labelSeenTE direct `thenTE` \ dlbl_seen -> - --labelSeenTE vectored `thenTE` \ vlbl_seen -> - let - ddcl = {-if dlbl_seen then empty else-} pprExternDecl direct CodePtrRep - vdcl = {-if vlbl_seen then empty else-} pprExternDecl vectored DataPtrRep - in - returnTE (Nothing, - if ({-dlbl_seen ||-} not (needsCDecl direct)) && - ({-vlbl_seen ||-} not (needsCDecl vectored)) then Nothing - else Just (hcat [ptext SLIT("UNVEC"),char '(', ddcl, comma, vdcl, rparen])) - -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 @@ -1473,3 +1707,102 @@ ppr_decls_Amodes amodes = mapTE ppr_decls_Amode amodes `thenTE` \ ps -> returnTE ( maybe_vcat ps ) \end{code} + +Print out a C Label where you want the *address* of the label, not the +object it refers to. The distinction is important when the label may +refer to a C structure (info tables and closures, for instance). + +When just generating a declaration for the label, use pprCLabel. + +\begin{code} +pprCLabelAddr :: CLabel -> SDoc +pprCLabelAddr clabel = + case labelType clabel of + InfoTblType -> addr_of_label + RetInfoTblType -> addr_of_label + ClosureType -> addr_of_label + VecTblType -> addr_of_label + DataType -> addr_of_label + + _ -> pp_label + where + addr_of_label = ptext SLIT("(P_)&") <> pp_label + pp_label = pprCLabel clabel +\end{code} + +----------------------------------------------------------------------------- +Initialising static objects with floating-point numbers. We can't +just emit the floating point number, because C will cast it to an int +by rounding it. We want the actual bit-representation of the float. + +This is a hack to turn the floating point numbers into ints that we +can safely initialise to static locations. + +\begin{code} +big_doubles = (getPrimRepSize DoubleRep) /= 1 + +#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) + arr' <- castFloatToIntArray arr + i <- readIntArray arr' 0 + return (CLit (MachInt (toInteger i))) + ) + +doubleToWords :: CAddrMode -> [CAddrMode] +doubleToWords (CLit (MachDouble r)) + | big_doubles -- doubles are 2 words + = runST (do + arr <- newDoubleArray ((0::Int),1) + writeDoubleArray arr 0 (fromRational r) + arr' <- castDoubleToIntArray arr + i1 <- readIntArray arr' 0 + i2 <- readIntArray arr' 1 + return [ CLit (MachInt (toInteger i1)) + , CLit (MachInt (toInteger i2)) + ] + ) + | otherwise -- doubles are 1 word + = runST (do + arr <- newDoubleArray ((0::Int),0) + writeDoubleArray arr 0 (fromRational r) + arr' <- castDoubleToIntArray arr + i <- readIntArray arr' 0 + return [ CLit (MachInt (toInteger i)) ] + ) +\end{code}