X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=f0ae17779fd930486f88a9d915cbd7c0648d3a7c;hb=a7d8f43718b167689c0a4a4c23b33a325e0239f1;hp=7c869bfb3a3b4f1735d2add79e26a3f399cd35f5;hpb=d4e0a55c3761544989209a2180d6d0489470db3d;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 7c869bf..f0ae177 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -19,48 +19,56 @@ module PprAbsC ( import IO ( Handle ) +import PrimRep import AbsCSyn import ClosureInfo import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import Constants ( mIN_UPD_SIZE ) -import CallConv ( CallConv, callConvAttribute ) -import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel, - needsCDecl, pprCLabel, +import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, + playThreadSafe, ccallConvAttribute, + ForeignCall(..), Safety(..), DNCallSpec(..), + DNType(..), DNKind(..) ) +import CLabel ( externallyVisibleCLabel, + needsCDecl, pprCLabel, mkClosureLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, - mkClosureLabel, 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, pprCLabelString ) +import CStrings ( pprCLabelString ) import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) -import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId ) -import Maybes ( maybeToBool, catMaybes ) -import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp, - PrimOp(..), CCall(..), CCallTarget(..) ) -import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep ) -import SMRep ( pprSMRep ) +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 ( SRT(..) ) -import BitSet ( intBS ) +import StgSyn ( StgOp(..) ) import Outputable -import Util ( nOfThem ) -import Addr ( Addr ) +import FastString +import Util ( lengthExceeds ) -import ST -import MutableArray +#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} @@ -151,7 +159,7 @@ pprAbsC (CReturn am return_info) c 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. @@ -185,7 +193,7 @@ pprAbsC (CSwitch discrim [(tag1@(MachInt i1), alt_code1), 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) @@ -214,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 (CCallOp ccall) args vol_regs) _ - = pprCCall ccall 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 @@ -240,7 +248,7 @@ pprAbsC stmt@(COpStmt results op args vol_regs) _ 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)), @@ -250,6 +258,37 @@ pprAbsC stmt@(COpStmt results op args 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 @@ -258,15 +297,15 @@ pprAbsC stmt@(CSRT lbl closures) c <> ptext SLIT("};") } -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("}};") - ] +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("}}")] @@ -280,12 +319,12 @@ pprAbsC (CMacroStmt macro as) _ = hcat [ptext (cStmtMacroText macro), lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting pprAbsC (CCallProfCtrMacro op as) _ - = hcat [ptext op, lparen, + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] pprAbsC (CCallProfCCMacro op as) _ - = hcat [ptext op, lparen, + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results args) _ +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 @@ -323,51 +362,52 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar -} fun_nm - | is_tdef = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty) - | otherwise = text (callConvAttribute cconv) <+> ccall_fun_ty + | 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 u -> ptext SLIT("_ccall_fun_ty") <> ppr u - StaticTarget x -> pprCLabelString x + 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 | is_tdef = tail ccall_arg_tys | otherwise = ccall_arg_tys - ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args + 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 lbl abs_C) _ - = if not (maybeToBool(nonemptyAbsC abs_C)) then + = 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 [ - char ' ', + empty, + pp_exts, hcat [text (if (externallyVisibleCLabel lbl) then "FN_(" -- abbreviations to save on output - else "IFN_("), + else "IF_("), pprCLabel lbl, text ") {"], - pp_exts, pp_temps, + pp_temps, nest 8 (ptext SLIT("FB_")), nest 8 (pprAbsC abs_C (costs abs_C)), @@ -377,15 +417,17 @@ pprAbsC (CCodeBlock lbl abs_C) _ } -pprAbsC (CInitHdr cl_info amode cost_centre) _ +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), + 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 [ @@ -399,174 +441,58 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ ppLocalnessMacro True{-include dyn-} info_lbl, char ')' ], - nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)), + nest 2 (ppr_payload amodes), ptext SLIT("};") ] } where - info_lbl = infoTableLabelFromCI cl_info + info_lbl = infoTableLabelFromCI cl_info ppr_payload [] = empty - ppr_payload ls = comma <+> - braces (hsep (punctuate comma (map ((text "(L_)" <>).ppr_item) ls))) - - ppr_item item - | rep == VoidRep = text "0" -- might not even need this... - | rep == FloatRep = ppr_amode (floatToWord item) - | rep == DoubleRep = hcat (punctuate (text ", (L_)") - (map ppr_amode (doubleToWords item))) - | otherwise = ppr_amode item + ppr_payload ls = + comma <+> + (braces $ hsep $ punctuate comma $ + map (text "(L_)" <>) (foldr ppr_item [] ls)) + + ppr_item item rest + | rep == VoidRep = rest + | rep == FloatRep = ppr_amode (floatToWord item) : rest + | rep == DoubleRep = map ppr_amode (doubleToWords item) ++ rest + | otherwise = ppr_amode item : rest where - rep = getAmodeRep item - - 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 + rep = getAmodeRep item - static_link_field - | staticClosureNeedsLink cl_info = [mkIntCLit 0] - | otherwise = [] - -pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ - = vcat [ - hcat [ - ptext SLIT("INFO_TABLE"), - ( if is_selector then - ptext SLIT("_SELECTOR") - else if is_constr then - ptext SLIT("_CONSTR") - else if needs_srt then - ptext SLIT("_SRT") - else empty ), char '(', - - pprCLabel info_lbl, comma, - pprCLabel slow_lbl, comma, - pp_rest, {- ptrs,nptrs,[srt,]type,-} comma, - - ppLocalness info_lbl, comma, - ppLocalnessMacro True{-include dyn-} slow_lbl, 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) - ] +pprAbsC stmt@(CClosureInfoAndCode cl_info entry) _ + = pprWordArray info_lbl (mkInfoTable cl_info) + $$ let stuff = CCodeBlock entry_lbl entry in + pprAbsC stuff (costs stuff) where - info_lbl = infoTableLabelFromCI cl_info - fast_lbl = fastLabelFromCI 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 - - maybe_tag = closureSemiTag cl_info - is_constr = maybeToBool maybe_tag - (Just tag) = maybe_tag - - needs_srt = infoTblNeedsSRT cl_info - srt = getSRTInfo cl_info - - size = closureNonHdrSize cl_info - - ptrs = closurePtrsSize cl_info - nptrs = size - ptrs - - pp_rest | is_selector = int select_word_i - | otherwise = hcat [ - int ptrs, comma, - int nptrs, comma, - if is_constr then - hcat [ int tag, comma ] - else if needs_srt then - pp_srt_info srt - else empty, - type_str ] - - 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 '"'] + 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 . dataConWrapId) (tyConDataCons tycon) + map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon) ) ) $$ ptext SLIT("};") pprAbsC stmt@(CRetDirect uniq code srt liveness) _ - = vcat [ - hcat [ - ptext SLIT("INFO_TABLE_SRT_BITMAP"), lparen, - pprCLabel info_lbl, comma, - pprCLabel entry_lbl, comma, - pp_liveness liveness, comma, -- bitmap - pp_srt_info srt, -- SRT - ptext type_str, comma, -- closure type - ppLocalness info_lbl, comma, -- info table storage class - ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class - int 0, comma, - int 0, text ");" - ], - pp_code - ] + = 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 - 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") - pprAbsC stmt@(CRetVector lbl amodes srt liveness) _ - = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> - vcat [ - pp_exts, - hcat [ - ptext SLIT("VEC_INFO_") <> int size, - lparen, - pprCLabel lbl, comma, - pp_liveness liveness, comma, -- bitmap liveness mask - pp_srt_info srt, -- SRT - ptext type_str, comma, - ppLocalness lbl, comma - ], - nest 2 (sep (punctuate comma (map ppr_item amodes))), - text ");" - ] - } - - where - ppr_item item = (<>) (text "(F_) ") (ppr_amode item) - size = length amodes + = pprWordArray lbl (mkVecInfoTable amodes srt liveness) - type_str = case liveness of - LvSmall _ -> SLIT("RET_VEC_SMALL") - LvLarge _ -> SLIT("RET_VEC_BIG") - - -pprAbsC stmt@(CModuleInitBlock lbl code) _ +pprAbsC stmt@(CModuleInitBlock plain_lbl lbl code) _ = vcat [ - ptext SLIT("START_MOD_INIT") <> parens (pprCLabel lbl), + ptext SLIT("START_MOD_INIT") <> + parens (pprCLabel plain_lbl <> comma <> pprCLabel lbl), case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> pp_exts }, pprAbsC code (costs code), hcat [ptext SLIT("END_MOD_INIT"), lparen, rparen] @@ -576,7 +502,150 @@ pprAbsC (CCostCentreDecl is_local cc) _ = pprCostCentreDecl is_local cc pprAbsC (CCostCentreStackDecl ccs) _ = pprCostCentreStackDecl ccs \end{code} +Info tables... just arrays of words (the translation is done in +ClosureInfo). + \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} + +\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 @@ -590,25 +659,24 @@ ppLocalnessMacro include_dyn_prefix clabel = 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_") + 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 is_visible = externallyVisibleCLabel clabel label_type = labelType clabel - is_dynamic = labelDynamic clabel visiblity_prefix | is_visible = char 'E' | otherwise = char 'I' dyn_prefix - | not include_dyn_prefix = empty - | is_dynamic = char 'D' - | otherwise = empty + | include_dyn_prefix && labelDynamic clabel = char 'D' + | otherwise = empty \end{code} @@ -625,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) @@ -638,7 +715,7 @@ 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, Sp, Su, 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 @@ -649,22 +726,6 @@ 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 ] -\end{code} - -\begin{code} pp_closure_lbl lbl | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl) | otherwise = char '&' <> pprCLabel lbl @@ -683,33 +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(" == ") - , 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 other of - MachInt _ -> ptext SLIT("(I_)") - _ -> empty - 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 [ @@ -778,73 +833,132 @@ 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 call@(CCall op_str is_asm may_gc cconv) args results vol_regs - = vcat [ - char '{', - 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 "{ I_ id; SUSPEND_THREAD(id);" - , text "RESUME_THREAD(id);}" - ) + + 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 = take (length args - 1) args - in ASSERT2 ( all non_void nvas, pprCCallOp call <+> hsep (map pprAmode args) ) - nvas + 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..] ] - 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 - DynamicTarget u -> ppr u - _ -> empty - (declare_local_vars, local_vars, assign_results) - = ppr_casm_results non_void_results + = ppr_casm_results non_void_results forDotnet - (StaticTarget asm_str) = op_str - is_dynamic = - case op_str of - StaticTarget _ -> False - DynamicTarget _ -> True + 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 @@ -854,19 +968,50 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs 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 and @ByteArray@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 @@ -878,25 +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 -> (pp_kind, - hcat [ptext SLIT("ForeignObj_CLOSURE_DATA"), - char '(', pp_amode, char ')']) - - other -> (pp_kind, pp_amode) - declare_local_var - = hcat [ arg_type, space, local_var, equals, pp_amode2, semi ] + = hcat [ pp_kind, space, local_var, equals, pp_amode, semi ] in (declare_local_var, local_var) \end{code} @@ -910,31 +1038,35 @@ For l-values, the critical questions are: \begin{code} ppr_casm_results :: [CAddrMode] -- list of results (length <= 1) + -> 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 [] +ppr_casm_results [] _ = (empty, [], empty) -- no results -ppr_casm_results [r] - = 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) = (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 - = panic "ppr_casm_results: ccall/casm with many results" \end{code} @@ -955,7 +1087,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 @@ -978,7 +1110,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") @@ -1010,15 +1142,15 @@ Special treatment for floats and doubles, to avoid unwanted conversions. \begin{code} pprAssign FloatRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_FLT"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_FLT((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] pprAssign DoubleRep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_DBL"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_DBL((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] pprAssign Int64Rep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_Int64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_Int64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] pprAssign Word64Rep dest@(CVal reg_rel _) src - = hcat [ ptext SLIT("ASSIGN_Word64"),char '(', ppr_amode (CAddr reg_rel), comma, pprAmode src, pp_paren_semi ] + = hcat [ ptext SLIT("ASSIGN_Word64((W_*)"), parens (ppr_amode (CAddr reg_rel)), comma, pprAmode src, pp_paren_semi ] \end{code} Lastly, the question is: will the C compiler think the types of the @@ -1051,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 iff the source is mixed - = hcat [ ppr_amode dest, equals, - text "(StgByteArray)(", -- Here is the cast - ppr_amode src, pp_paren_semi ] - pprAssign kind other_dest src = hcat [ ppr_amode other_dest, equals, pprAmode src, semi ] @@ -1087,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 @@ -1108,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} @@ -1119,7 +1267,7 @@ 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 @@ -1134,14 +1282,11 @@ ppr_amode (CIntLike int) ppr_amode (CLit lit) = pprBasicLit lit -ppr_amode (CLitLit str _) = ptext str - ppr_amode (CJoinPoint _) = panic "ppr_amode: CJoinPoint" ppr_amode (CMacroExpr pk macro as) - = parens (pprPrimKind pk) <> - parens (ptext (cExprMacroText macro) <> + = parens (ptext (cExprMacroText macro) <> parens (hcat (punctuate comma (map pprAmode as)))) \end{code} @@ -1150,18 +1295,20 @@ 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 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 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") @@ -1171,18 +1318,16 @@ 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_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_UT_ALT = SLIT("HP_CHK_UT_ALT") -cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") +cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE") \end{code} %************************************************************************ @@ -1192,15 +1337,8 @@ cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") %************************************************************************ \begin{code} -pp_liveness :: Liveness -> SDoc -pp_liveness lv = - case lv of - LvLarge lbl -> char '&' <> pprCLabel lbl - LvSmall mask -- Avoid gcc bug when printing minInt - | bitmap_int == minInt -> int (bitmap_int+1) <> text "-1" - | otherwise -> int bitmap_int - where - bitmap_int = intBS mask +bitmapAddrModes [] = [mkWordCLit 0] +bitmapAddrModes xs = map mkWordCLit xs \end{code} %************************************************************************ @@ -1265,19 +1403,18 @@ 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") pprMagicId Hp = ptext SLIT("Hp") 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 @@ -1288,21 +1425,16 @@ 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 StableNameRep = char 'p' -pprUnionTag WeakPtrRep = char 'p' -pprUnionTag ForeignObjRep = char 'p' - -pprUnionTag ThreadIdRep = char 't' - -pprUnionTag ArrayRep = char 'p' -pprUnionTag ByteArrayRep = char 'b' +pprUnionTag StablePtrRep = char 'p' pprUnionTag _ = panic "pprUnionTag:Odd kind" \end{code} @@ -1463,7 +1595,7 @@ ppr_decls_AbsC (CSwitch discrim alts deflt) 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, @@ -1474,8 +1606,14 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre) where info_lbl = infoTableLabelFromCI cl_info +ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (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 (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 -> @@ -1490,24 +1628,18 @@ 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 _) +ppr_decls_AbsC (CClosureInfoAndCode cl_info entry) = ppr_decls_Amodes [entry_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]) + ppr_decls_AbsC entry `thenTE` \ p2 -> + returnTE (maybe_vcat [p1, p2]) where - entry_lbl = CLbl slow_lbl CodePtrRep - slow_lbl = case (nonemptyAbsC slow) of - Nothing -> mkErrorStdEntryLabel - Just _ -> entryLabelFromCI cl_info + entry_lbl = CLbl (entryLabelFromCI cl_info) CodePtrRep -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 @@ -1516,7 +1648,7 @@ ppr_decls_AbsC (CSRT lbl closure_lbls) ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes -ppr_decls_AbsC (CModuleInitBlock _ code) = ppr_decls_AbsC code +ppr_decls_AbsC (CModuleInitBlock _ _ code) = ppr_decls_AbsC code ppr_decls_AbsC (_) = returnTE (Nothing, Nothing) \end{code} @@ -1529,14 +1661,12 @@ ppr_decls_Amode (CVal _ _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CAddr _) = returnTE (Nothing, Nothing) ppr_decls_Amode (CReg _) = 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) @@ -1588,14 +1718,16 @@ When just generating a declaration for the label, use pprCLabel. pprCLabelAddr :: CLabel -> SDoc pprCLabelAddr clabel = case labelType clabel of - InfoTblType -> addr_of_label - ClosureType -> addr_of_label - VecTblType -> addr_of_label - _ -> pp_label + 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} ----------------------------------------------------------------------------- @@ -1609,13 +1741,46 @@ can safely initialise to static locations. \begin{code} big_doubles = (getPrimRepSize DoubleRep) /= 1 --- floatss are always 1 word +#if __GLASGOW_HASKELL__ >= 504 +newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float) +newFloatArray = newArray_ + +newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double) +newDoubleArray = newArray_ + +castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int) +castFloatToIntArray = castSTUArray + +castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int) +castDoubleToIntArray = castSTUArray + +writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s () +writeFloatArray = writeArray + +writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s () +writeDoubleArray = writeArray + +readIntArray :: STUArray s Int Int -> Int -> ST s Int +readIntArray = readArray + +#else + +castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t) +castFloatToIntArray = return + +castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t) +castDoubleToIntArray = return + +#endif + +-- floats are always 1 word floatToWord :: CAddrMode -> CAddrMode floatToWord (CLit (MachFloat r)) = runST (do arr <- newFloatArray ((0::Int),0) writeFloatArray arr 0 (fromRational r) - i <- readIntArray arr 0 + arr' <- castFloatToIntArray arr + i <- readIntArray arr' 0 return (CLit (MachInt (toInteger i))) ) @@ -1625,8 +1790,9 @@ doubleToWords (CLit (MachDouble r)) = runST (do arr <- newDoubleArray ((0::Int),1) writeDoubleArray arr 0 (fromRational r) - i1 <- readIntArray arr 0 - i2 <- readIntArray arr 1 + arr' <- castDoubleToIntArray arr + i1 <- readIntArray arr' 0 + i2 <- readIntArray arr' 1 return [ CLit (MachInt (toInteger i1)) , CLit (MachInt (toInteger i2)) ] @@ -1635,7 +1801,8 @@ doubleToWords (CLit (MachDouble r)) = runST (do arr <- newDoubleArray ((0::Int),0) writeDoubleArray arr 0 (fromRational r) - i <- readIntArray arr 0 + arr' <- castDoubleToIntArray arr + i <- readIntArray arr' 0 return [ CLit (MachInt (toInteger i)) ] ) \end{code}