X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=a36a356d6d912088310bae684f61ff85eac3cf78;hb=4e0c994eb1613c62e94069642d7acdb2e69b773b;hp=374058f4be869c49435e481bc7b0f1813e421196;hpb=e6243a818496aad82b6f47511d3bd9bc800f747d;p=ghc-hetmet.git diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 374058f..a36a356 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -44,17 +44,20 @@ import ClosureInfo import DynFlags import Unique import UniqSet -import FiniteMap import UniqFM import FastString import Outputable import Constants +import BasicTypes +import CLabel -- The rest import Data.List import Data.Bits import Data.Char import System.IO +import Data.Map (Map) +import qualified Data.Map as Map import Data.Word import Data.Array.ST @@ -90,7 +93,7 @@ writeCs dflags handle cmms -- pprC :: RawCmm -> SDoc -pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops +pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops -- -- top level procs @@ -105,7 +108,7 @@ pprTop (CmmProc info clbl _params (ListGraph blocks)) = [] -> empty -- the first block doesn't get a label: (BasicBlock _ stmts : rest) -> vcat [ - text "", + blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, @@ -143,8 +146,9 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = -- Floating info table for safe a foreign call. pprTop top@(CmmData _section d@(_ : _)) | CmmDataLabel lbl : lits <- reverse d = - pprDataExterns lits $$ - pprWordArray lbl lits + let lits' = reverse lits + in pprDataExterns lits' $$ + pprWordArray lbl lits' -- these shouldn't appear? pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" @@ -191,7 +195,11 @@ pprStmt :: CmmStmt -> SDoc pprStmt stmt = case stmt of CmmNop -> empty - CmmComment s -> (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") + CmmComment s -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") + -- XXX if the string contains "*/", we need to fix it + -- XXX we probably want to emit these comments when + -- some debugging option is on. They can get quite + -- large. CmmAssign dest src -> pprAssign dest src @@ -208,7 +216,7 @@ pprStmt stmt = case stmt of CmmCall (CmmCallee fn cconv) results args safety ret -> maybe_proto $$ - pprCall ppr_fn cconv results args safety + fnCall where cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) @@ -216,7 +224,7 @@ pprStmt stmt = case stmt of pprCFunType (pprCLabel lbl) cconv results args <> noreturn_attr <> semi - data_proto lbl = ptext (sLit ";EI_(") <> + fun_proto lbl = ptext (sLit ";EF_(") <> pprCLabel lbl <> char ')' <> semi noreturn_attr = case ret of @@ -224,26 +232,30 @@ pprStmt stmt = case stmt of CmmMayReturn -> empty -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - (maybe_proto, ppr_fn) = + (maybe_proto, fnCall) = case fn of CmmLit (CmmLabel lbl) - | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl) + | StdCallConv <- cconv -> + let myCall = pprCall (pprCLabel lbl) cconv results args safety + in (real_fun_proto lbl, myCall) -- stdcall functions must be declared with -- a function type, otherwise the C compiler -- doesn't add the @n suffix to the label. We -- can't add the @n suffix ourselves, because -- it isn't valid C. - | CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl) - | not (isMathFun lbl) -> (data_proto lbl, cast_fn) - -- we declare all other called functions as - -- data labels, and then cast them to the - -- right type when calling. This is because - -- the label might already have a declaration - -- as a data label in the same file, - -- e.g. Foreign.Marshal.Alloc declares 'free' - -- as both a data label and a function label. + | CmmNeverReturns <- ret -> + let myCall = pprCall (pprCLabel lbl) cconv results args safety + in (real_fun_proto lbl, myCall) + | not (isMathFun lbl) -> + let myCall = braces ( + pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi + $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi + $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi + ) + in (fun_proto lbl, myCall) _ -> - (empty {- no proto -}, cast_fn) + (empty {- no proto -}, + pprCall cast_fn cconv results args safety <> semi) -- for a dynamic call, no declaration is necessary. CmmCall (CmmPrim op) results args safety _ret -> @@ -668,22 +680,11 @@ mkFE_ = ptext (sLit "FE_") -- function code end -- from includes/Stg.h -- -mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc +mkC_,mkW_,mkP_ :: SDoc mkC_ = ptext (sLit "(C_)") -- StgChar mkW_ = ptext (sLit "(W_)") -- StgWord mkP_ = ptext (sLit "(P_)") -- StgWord* -mkPP_ = ptext (sLit "(PP_)") -- P_* -mkI_ = ptext (sLit "(I_)") -- StgInt -mkA_ = ptext (sLit "(A_)") -- StgAddr -mkD_ = ptext (sLit "(D_)") -- const StgWord* -mkF_ = ptext (sLit "(F_)") -- StgFunPtr -mkB_ = ptext (sLit "(B_)") -- StgByteArray -mkL_ = ptext (sLit "(L_)") -- StgClosurePtr - -mkLI_ = ptext (sLit "(LI_)") -- StgInt64 -mkLW_ = ptext (sLit "(LW_)") -- StgWord64 - -- --------------------------------------------------------------------- -- @@ -865,12 +866,12 @@ is_cish StdCallConv = True pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-}) pprTempAndExternDecls stmts = (vcat (map pprTempDecl (uniqSetToList temps)), - vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))) + vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))) where (temps, lbls) = runTE (mapM_ te_BB stmts) pprDataExterns :: [CmmStatic] -> SDoc pprDataExterns statics - = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)) + = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)) where (_, lbls) = runTE (mapM_ te_Static statics) pprTempDecl :: LocalReg -> SDoc @@ -901,7 +902,7 @@ pprExternDecl in_srt lbl <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth))) <> semi -type TEState = (UniqSet LocalReg, FiniteMap CLabel ()) +type TEState = (UniqSet LocalReg, Map CLabel ()) newtype TE a = TE { unTE :: TEState -> (a, TEState) } instance Monad TE where @@ -909,13 +910,13 @@ instance Monad TE where return a = TE $ \s -> (a, s) te_lbl :: CLabel -> TE () -te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ())) +te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) te_temp :: LocalReg -> TE () te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls)) runTE :: TE () -> TEState -runTE (TE m) = snd (m (emptyUniqSet, emptyFM)) +runTE (TE m) = snd (m (emptyUniqSet, Map.empty)) te_Static :: CmmStatic -> TE () te_Static (CmmStaticLit lit) = te_Lit lit