X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FPprC.hs;h=d363cef50b19b8b34cb296fd240be319aa79f8fe;hp=fea2374a9e48323b2569a2441e456103c1bc1b93;hb=cf5905ea24904cf73a041fd7535e8723a668cb9a;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index fea2374..d363cef 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -34,8 +34,8 @@ module PprC ( -- Cmm stuff import BlockId -import Cmm -import PprCmm () -- Instances only +import OldCmm +import OldPprCmm () -- Instances only import CLabel import ForeignCall import ClosureInfo @@ -44,17 +44,21 @@ import ClosureInfo import DynFlags import Unique import UniqSet -import FiniteMap import UniqFM import FastString import Outputable import Constants +import BasicTypes +import CLabel +import Util -- 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,29 +94,30 @@ 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 -- pprTop :: RawCmmTop -> SDoc -pprTop (CmmProc info clbl _params (ListGraph blocks)) = +pprTop (CmmProc info clbl (ListGraph blocks)) = (if not (null info) then pprDataExterns info $$ pprWordArray (entryLblToInfoLbl clbl) info else empty) $$ - (case blocks of - [] -> empty - -- the first block doesn't get a label: - (BasicBlock _ stmts : rest) -> vcat [ - text "", + (vcat [ + blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + case blocks of + [] -> empty + -- the first block doesn't get a label: + (BasicBlock _ stmts : rest) -> + nest 8 (vcat (map pprStmt stmts)) $$ + vcat (map pprBBlock rest), nest 8 mkFE_, rbrace ] ) @@ -140,6 +145,13 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = pprDataExterns lits $$ pprWordArray lbl lits +-- Floating info table for safe a foreign call. +pprTop top@(CmmData _section d@(_ : _)) + | CmmDataLabel lbl : lits <- reverse d = + let lits' = reverse lits + in pprDataExterns lits' $$ + pprWordArray lbl lits' + -- these shouldn't appear? pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" @@ -185,7 +197,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 @@ -202,7 +218,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) @@ -210,7 +226,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 @@ -218,26 +234,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 || isCas 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 -> @@ -432,6 +452,8 @@ pprLit lit = case lit of -- these constants come from -- see #1861 + CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) + CmmHighStackMark -> panic "PprC printing high stack mark" CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i CmmLabelDiffOff clbl1 clbl2 i @@ -660,22 +682,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 - -- --------------------------------------------------------------------- -- @@ -857,12 +868,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 @@ -893,7 +904,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 @@ -901,13 +912,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 @@ -1013,18 +1024,6 @@ machRep_S_CType _ = panic "machRep_S_CType" pprStringInCStyle :: [Word8] -> SDoc pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -- --------------------------------------------------------------------------- -- Initialising static objects with floating-point numbers. We can't -- just emit the floating point number, because C will cast it to an int