X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fcmm%2FPprC.hs;h=aa7d914253100e0654a3536107d1c94bb19c3809;hb=7b5b3b0cab463e108a0132435a28ef19d17cb32b;hp=3ee3738e7b9bb8e5e4cc47b9eb4236ee5c7e1143;hpb=8fd6a1efca90be81dc97a679bf430aaffecc568d;p=ghc-hetmet.git diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 3ee3738..aa7d914 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,28 +44,26 @@ 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 import Control.Monad.ST -#if x86_64_TARGET_ARCH -import StaticFlags ( opt_Unregisterised ) -#endif - #if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH) #define BEWARE_LOAD_STORE_ALIGNMENT #endif @@ -92,29 +90,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 ] ) @@ -679,22 +678,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 - -- --------------------------------------------------------------------- -- @@ -828,17 +816,6 @@ pprCall ppr_fn cconv results args _ | otherwise = -#if x86_64_TARGET_ARCH - -- HACK around gcc optimisations. - -- x86_64 needs a __DISCARD__() here, to create a barrier between - -- putting the arguments into temporaries and passing the arguments - -- to the callee, because the argument expressions may refer to - -- machine registers that are also used for passing arguments in the - -- C calling convention. - (if (not opt_Unregisterised) - then ptext (sLit "__DISCARD__();") - else empty) $$ -#endif ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs @@ -876,12 +853,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 @@ -912,7 +889,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 @@ -920,13 +897,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 @@ -1032,18 +1009,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