X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FabsCSyn%2FPprAbsC.lhs;h=300b5f4fff3dfcc251b64d12bea6520a1a8f357e;hb=3f5e4368fd4e87e116ce34be4cf9dd0f9f96726d;hp=d9dcea9f31812462c9ebccf855c2b09b5a9361c9;hpb=9b3d7ebd00f00e953e61dbf62a1045ff7ba910dd;p=ghc-hetmet.git diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index d9dcea9..300b5f4 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -26,12 +26,13 @@ import AbsCUtils ( getAmodeRep, nonemptyAbsC, mixedPtrLocn, mixedTypeLocn ) -import Constants ( mIN_UPD_SIZE ) -import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, ccallConvAttribute ) +import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe, + playThreadSafe, ccallConvAttribute, + ForeignCall(..), DNCallSpec(..), + DNType(..), DNKind(..) ) import CLabel ( externallyVisibleCLabel, - needsCDecl, pprCLabel, + needsCDecl, pprCLabel, mkClosureLabel, mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel, - mkClosureLabel, mkErrorStdEntryLabel, CLabel, CLabelType(..), labelType, labelDynamic ) @@ -39,30 +40,35 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl ) import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) -import CStrings ( pprStringInCStyle, pprCLabelString ) +import CStrings ( pprCLabelString ) import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) -import DataCon ( dataConWrapId ) -import Maybes ( maybeToBool, catMaybes ) +import Maybes ( catMaybes ) import PrimOp ( primOpNeedsWrapper ) import MachOp ( MachOp(..) ) -import ForeignCall ( ForeignCall(..) ) -import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, getPrimRepArrayElemSize ) -import SMRep ( pprSMRep ) +import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, addOneToUniqSet, UniqSet ) import StgSyn ( StgOp(..) ) -import BitSet ( BitSet, intBS ) import Outputable -import GlaExts -import Util ( nOfThem, lengthExceeds, listLengthCmp ) -import Maybe ( isNothing, maybeToList ) +import FastString +import Util ( lengthExceeds ) -import ST +#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} @@ -187,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) @@ -254,32 +260,7 @@ pprAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs) _ -- NEW CASES FOR EXPANDED PRIMOPS --- We have to deal with some of these specially -pprAbsC (CMachOpStmt (Just res) (MO_ReadOSBI offw scaleRep) - [baseAmode, indexAmode] maybe_vols) - _ - | isNothing maybe_vols - = hcat [ -- text " /* ReadOSBI */ ", - ppr_amode res, equals, - ppr_array_expression offw scaleRep baseAmode indexAmode, - semi ] - | otherwise - = panic "pprAbsC:MO_ReadOSBI -- out-of-line array indexing ?!?!" - -pprAbsC (CMachOpStmt Nothing (MO_WriteOSBI offw scaleRep) - [baseAmode, indexAmode, vAmode] maybe_vols) - _ - | isNothing maybe_vols - = hcat [ -- text " /* WriteOSBI */ ", - ppr_array_expression offw scaleRep baseAmode indexAmode, - equals, pprAmode vAmode, - semi ] - | otherwise - = panic "pprAbsC:MO_WriteOSBI -- out-of-line array indexing ?!?!" - --- The rest generically. - -pprAbsC stmt@(CMachOpStmt (Just res) mop [arg1,arg2] maybe_vols) _ +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) -> @@ -294,7 +275,7 @@ pprAbsC stmt@(CMachOpStmt (Just res) mop [arg1,arg2] maybe_vols) _ $$ restores } -pprAbsC stmt@(CMachOpStmt (Just res) mop [arg1] maybe_vols) _ +pprAbsC stmt@(CMachOpStmt res mop [arg1] maybe_vols) _ = case ppr_maybe_vol_regs maybe_vols of {(saves,restores) -> saves $$ hcat [ppr_amode res, equals, @@ -316,12 +297,15 @@ pprAbsC stmt@(CSRT lbl closures) c <> ptext SLIT("};") } -pprAbsC stmt@(CBitmap lbl mask) c - = pp_bitmap_switch mask semi $ - hcat [ ptext SLIT("BITMAP"), lparen, - pprCLabel lbl, comma, - int (length mask), comma, - pp_bitmap mask, rparen ] +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("}}")] @@ -335,10 +319,10 @@ pprAbsC (CMacroStmt macro as) _ = hcat [ptext (cStmtMacroText macro), lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] -- no casting pprAbsC (CCallProfCtrMacro op as) _ - = hcat [ptext op, lparen, + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] pprAbsC (CCallProfCCMacro op as) _ - = hcat [ptext op, lparen, + = hcat [ftext op, lparen, hcat (punctuate comma (map ppr_amode as)),pp_paren_semi] pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) _ = hsep [ ptext (if is_tdef then SLIT("typedef") else SLIT("extern")) @@ -411,7 +395,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args) 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) -> @@ -420,7 +404,7 @@ pprAbsC (CCodeBlock lbl abs_C) _ pp_exts, hcat [text (if (externallyVisibleCLabel lbl) then "FN_(" -- abbreviations to save on output - else "IFN_("), + else "IF_("), pprCLabel lbl, text ") {"], pp_temps, @@ -442,7 +426,8 @@ pprAbsC (CInitHdr cl_info amode cost_centre size) _ pp_paren_semi ] where info_lbl = infoTableLabelFromCI cl_info - + + pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ = case (pprTempAndExternDecls stmt) of { (_, pp_exts) -> vcat [ @@ -456,179 +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 - - upd_reqd = closureUpdReqd cl_info - - padding_wds - | not upd_reqd = [] - | otherwise = case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed -> - nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s + rep = getAmodeRep item - -- always have a static link field, it's used to save the closure's - -- info pointer when we're reverting CAFs (see comment in Storage.c) - static_link_field - | upd_reqd || staticClosureNeedsLink cl_info = [mkIntCLit 0] - | otherwise = [] - -pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ - = vcat [ - hcat [ - ptext SLIT("INFO_TABLE"), - ( 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 - - srt = closureSRT cl_info - needs_srt = case srt of - NoC_SRT -> False - other -> True - - - 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 = pprStringInCStyle cl_descr - pp_type = pprStringInCStyle (closureTypeDescr cl_info) + 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 - closure_type, 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) - - closure_type = pp_liveness_switch liveness - (ptext SLIT("RET_SMALL")) - (ptext SLIT("RET_BIG")) + info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq 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 - closure_type, 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 - - closure_type = pp_liveness_switch liveness - (ptext SLIT("RET_VEC_SMALL")) - (ptext SLIT("RET_VEC_BIG")) - + = pprWordArray lbl (mkVecInfoTable amodes srt liveness) -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] @@ -638,6 +502,22 @@ 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 '+' @@ -765,24 +645,6 @@ 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)" -pprMachOp_for_C (MO_ReadOSBI _ _) = panic "pprMachOp_for_C:MO_ReadOSBI" -pprMachOp_for_C (MO_WriteOSBI _ _) = panic "pprMachOp_for_C:MO_WriteOSBI" - - --- Helper for printing array expressions. -ppr_array_expression offw scaleRep baseAmode indexAmode - -- create: - -- * (scaleRep*) ( - -- ((char*)baseAmode) + offw*bytes_per_word + indexAmode*bytes_per_scaleRep - -- ) - = let offb = parens (int offw <> char '*' <> text "sizeof(void*)") - indb = parens (parens (pprAmode indexAmode) - <> char '*' <> int (getPrimRepArrayElemSize scaleRep)) - baseb = text "(char*)" <> parens (pprAmode baseAmode) - addr = parens baseb <+> char '+' <+> offb <+> char '+' <+> indb - in - char '*' <> parens (ppr scaleRep <> char '*') <> parens addr - ppLocalness lbl = if (externallyVisibleCLabel lbl) @@ -797,11 +659,12 @@ 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 @@ -852,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 @@ -863,15 +726,6 @@ pp_basic_restores = ptext SLIT("CALLER_RESTORE_SYSTEM") \end{code} \begin{code} -pp_srt_info NoC_SRT = hcat [ int 0, comma, - int 0, comma, - int 0, comma ] -pp_srt_info (C_SRT lbl off len) = hcat [ pprCLabel lbl, comma, - int off, comma, - int len, comma ] -\end{code} - -\begin{code} pp_closure_lbl lbl | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl) | otherwise = char '&' <> pprCLabel lbl @@ -979,25 +833,95 @@ 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} -pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs - = vcat [ - char '{', - declare_local_vars, -- local var for *result* - vcat local_arg_decls, - pp_save_context, - process_casm local_vars pp_non_void_args call_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) - | playSafe safety = ( 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 = init args @@ -1008,7 +932,7 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs non_void_results = let nvrs = grab_non_void_amodes results - in ASSERT (listLengthCmp nvrs 1 /= GT) 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. @@ -1016,12 +940,18 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs = unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ] (declare_local_vars, local_vars, assign_results) - = ppr_casm_results non_void_results + = ppr_casm_results non_void_results forDotnet + + forDotnet + = case call of + DNCall{} -> True + _ -> False - call_str = case target of - CasmTarget str -> _UNPK_ str - StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args - DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args) + 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) ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..] dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0") @@ -1037,13 +967,51 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs hcat (punctuate comma ccall_fun_args), text "));" ]) -\end{code} -If the argument is a heap object, we need to reach inside and pull out -the bit the C world wants to see. The only heap objects which can be -passed are @Array@s and @ByteArray@s. +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 @@ -1055,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} @@ -1087,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} @@ -1187,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 @@ -1228,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 ] @@ -1264,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 @@ -1300,13 +1248,6 @@ That is, the indexing is done in units of kind1, but the resulting amode has kind2. \begin{code} -ppr_amode CBytesPerWord - = text "(sizeof(void*))" - -ppr_amode (CMem rep addr) - = let txt_rep = pprPrimKind rep - in hcat [ char '*', parens (txt_rep <> char '*'), parens (ppr_amode addr) ] - ppr_amode (CVal reg_rel@(CIndex _ _ _) kind) = case (pprRegRelative False{-no sign wanted-} reg_rel) of (pp_reg, Nothing) -> panic "ppr_amode: CIndex" @@ -1326,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 @@ -1355,16 +1296,16 @@ 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") @@ -1377,21 +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") -\end{code} - -\begin{code} +cCheckMacroText HP_CHK_UNBX_TUPLE = SLIT("HP_CHK_UNBX_TUPLE") \end{code} %************************************************************************ @@ -1401,37 +1337,8 @@ cCheckMacroText HP_CHK_GEN = SLIT("HP_CHK_GEN") %************************************************************************ \begin{code} -pp_bitmap_switch :: [BitSet] -> SDoc -> SDoc -> SDoc -pp_bitmap_switch ([ ]) small large = small -pp_bitmap_switch ([_ ]) small large = small -pp_bitmap_switch ([_,_]) small large = hcat - [ptext SLIT("BITMAP_SWITCH64"), lparen, small, comma, large, rparen] -pp_bitmap_switch (_ ) small large = large - -pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc -pp_liveness_switch (Liveness lbl mask) = pp_bitmap_switch mask - -pp_bitset :: BitSet -> SDoc -pp_bitset s - | i < -1 = int (i + 1) <> text "-1" - | otherwise = int i - where i = intBS s - -pp_bitmap :: [BitSet] -> SDoc -pp_bitmap [] = int 0 -pp_bitmap ss = hcat (punctuate delayed_comma (bundle ss)) where - delayed_comma = hcat [space, ptext SLIT("COMMA"), space] - bundle [] = [] - bundle [s] = [hcat bitmap32] - where bitmap32 = [ptext SLIT("BITMAP32"), lparen, - pp_bitset s, rparen] - bundle (s1:s2:ss) = hcat bitmap64 : bundle ss - where bitmap64 = [ptext SLIT("BITMAP64"), lparen, - pp_bitset s1, comma, pp_bitset s2, rparen] - -pp_liveness :: Liveness -> SDoc -pp_liveness (Liveness lbl mask) - = pp_bitmap_switch mask (pp_bitmap mask) (char '&' <> pprCLabel lbl) +bitmapAddrModes [] = [mkWordCLit 0] +bitmapAddrModes xs = map mkWordCLit xs \end{code} %************************************************************************ @@ -1500,12 +1407,11 @@ 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!" +pprMagicId VoidReg = ptext SLIT("VoidReg") pprVanillaReg :: Int# -> SDoc pprVanillaReg n = char 'R' <> int (I# n) @@ -1529,16 +1435,6 @@ pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" pprUnionTag StablePtrRep = char 'p' -pprUnionTag StableNameRep = char 'p' -pprUnionTag WeakPtrRep = char 'p' -pprUnionTag ForeignObjRep = char 'p' -pprUnionTag PrimPtrRep = char 'p' - -pprUnionTag ThreadIdRep = char 't' - -pprUnionTag ArrayRep = char 'p' -pprUnionTag ByteArrayRep = char 'b' -pprUnionTag BCORep = char 'p' pprUnionTag _ = panic "pprUnionTag:Odd kind" \end{code} @@ -1710,7 +1606,7 @@ ppr_decls_AbsC (CInitHdr cl_info reg_rel cost_centre _) where info_lbl = infoTableLabelFromCI cl_info -ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (maybeToList res ++ args) +ppr_decls_AbsC (CMachOpStmt res _ args _) = ppr_decls_Amodes (res : args) ppr_decls_AbsC (COpStmt results _ args _) = ppr_decls_Amodes (results ++ args) ppr_decls_AbsC (CSimultaneous abc) = ppr_decls_AbsC abc @@ -1732,22 +1628,16 @@ 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 _ closure_lbls) = mapTE labelSeenTE closure_lbls `thenTE` \ seen -> @@ -1758,7 +1648,7 @@ ppr_decls_AbsC (CSRT _ closure_lbls) ppr_decls_AbsC (CRetDirect _ code _ _) = ppr_decls_AbsC code ppr_decls_AbsC (CRetVector _ amodes _ _) = ppr_decls_Amodes amodes -ppr_decls_AbsC (CModuleInitBlock _ code) = ppr_decls_AbsC code +ppr_decls_AbsC (CModuleInitBlock _ _ code) = ppr_decls_AbsC code ppr_decls_AbsC (_) = returnTE (Nothing, Nothing) \end{code} @@ -1828,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} ----------------------------------------------------------------------------- @@ -1849,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))) ) @@ -1865,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)) ] @@ -1875,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}