Use SDoc rather than Doc in LLVM

In particular, this makes life simpler when we want to use a general
GHC SDoc in the middle of some LLVM.

compiler/llvmGen/Llvm.hs

@@ -49,7 +49,6 @@ module Llvm (
         ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
         ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
         ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
-        llvmSDoc
 
     ) where
 

compiler/llvmGen/Llvm/PpLlvm.hs

@@ -19,9 +19,6 @@ module Llvm.PpLlvm (
     ppLlvmFunctions,
     ppLlvmFunction,
 
-    -- * Utility functions
-    llvmSDoc
-
     ) where
 
 #include "HsVersions.h"
@@ -30,8 +27,7 @@ import Llvm.AbsSyn
 import Llvm.Types
 
 import Data.List ( intersperse )
-import Pretty
-import qualified Outputable as Out
+import Outputable
 import Unique
 
 --------------------------------------------------------------------------------
@@ -39,7 +35,7 @@ import Unique
 --------------------------------------------------------------------------------
 
 -- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmModule -> Doc
+ppLlvmModule :: LlvmModule -> SDoc
 ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
   = ppLlvmComments comments $+$ newLine
     $+$ ppLlvmAliases aliases $+$ newLine
@@ -49,20 +45,20 @@ ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
     $+$ ppLlvmFunctions funcs
 
 -- | Print out a multi-line comment, can be inside a function or on its own
-ppLlvmComments :: [LMString] -> Doc
+ppLlvmComments :: [LMString] -> SDoc
 ppLlvmComments comments = vcat $ map ppLlvmComment comments
 
 -- | Print out a comment, can be inside a function or on its own
-ppLlvmComment :: LMString -> Doc
+ppLlvmComment :: LMString -> SDoc
 ppLlvmComment com = semi <+> ftext com
 
 
 -- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: [LMGlobal] -> Doc
+ppLlvmGlobals :: [LMGlobal] -> SDoc
 ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
 
 -- | Print out a global mutable variable definition
-ppLlvmGlobal :: LMGlobal -> Doc
+ppLlvmGlobal :: LMGlobal -> SDoc
 ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
     let sect = case x of
             Just x' -> text ", section" <+> doubleQuotes (ftext x')
@@ -85,21 +81,21 @@ ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
 
 
 -- | Print out a list of LLVM type aliases.
-ppLlvmAliases :: [LlvmAlias] -> Doc
+ppLlvmAliases :: [LlvmAlias] -> SDoc
 ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
 
 -- | Print out an LLVM type alias.
-ppLlvmAlias :: LlvmAlias -> Doc
+ppLlvmAlias :: LlvmAlias -> SDoc
 ppLlvmAlias (name, ty)
   = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
 
 
 -- | Print out a list of LLVM metadata.
-ppLlvmMetas :: [LlvmMeta] -> Doc
+ppLlvmMetas :: [LlvmMeta] -> SDoc
 ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
 
 -- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmMeta -> Doc
+ppLlvmMeta :: LlvmMeta -> SDoc
 ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas)
   = exclamation <> int u <> text " = metadata !{" <>
     hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}"
@@ -112,7 +108,7 @@ ppLlvmMeta (MetaNamed n metas)
     pprNode n = exclamation <> int n
 
 -- | Print out an LLVM metadata value.
-ppLlvmMetaVal :: LlvmMetaVal -> Doc
+ppLlvmMetaVal :: LlvmMetaVal -> SDoc
 ppLlvmMetaVal (MetaStr  s) = text "metadata !" <> doubleQuotes (ftext s)
 ppLlvmMetaVal (MetaVar  v) = texts v
 ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
@@ -120,11 +116,11 @@ ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
 
 
 -- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmFunctions -> Doc
+ppLlvmFunctions :: LlvmFunctions -> SDoc
 ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
 
 -- | Print out a function definition.
-ppLlvmFunction :: LlvmFunction -> Doc
+ppLlvmFunction :: LlvmFunction -> SDoc
 ppLlvmFunction (LlvmFunction dec args attrs sec body) =
     let attrDoc = ppSpaceJoin attrs
         secDoc = case sec of
@@ -139,7 +135,7 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
         $+$ newLine
 
 -- | Print out a function defenition header.
-ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
 ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
   = let varg' = case varg of
                       VarArgs | null p    -> text "..."
@@ -155,13 +151,13 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
         (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
 
 -- | Print out a list of function declaration.
-ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
+ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
 
 -- | Print out a function declaration.
 -- Declarations define the function type but don't define the actual body of
 -- the function.
-ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
+ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
 ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
   = let varg' = case varg of
                       VarArgs | null p    -> text "..."
@@ -177,12 +173,12 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
 
 
 -- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmBlocks -> Doc
+ppLlvmBlocks :: LlvmBlocks -> SDoc
 ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
 
 -- | Print out an LLVM block.
 -- It must be part of a function definition.
-ppLlvmBlock :: LlvmBlock -> Doc
+ppLlvmBlock :: LlvmBlock -> SDoc
 ppLlvmBlock (LlvmBlock blockId stmts)
   = go blockId stmts
   where
@@ -201,12 +197,12 @@ ppLlvmBlock (LlvmBlock blockId stmts)
            $+$ ppRest
 
 -- | Print out an LLVM block label.
-ppLlvmBlockLabel :: LlvmBlockId -> Doc
-ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
+ppLlvmBlockLabel :: LlvmBlockId -> SDoc
+ppLlvmBlockLabel id = pprUnique id <> colon
 
 
 -- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmStatement -> Doc
+ppLlvmStatement :: LlvmStatement -> SDoc
 ppLlvmStatement stmt =
   let ind = (text "  " <>)
   in case stmt of
@@ -226,7 +222,7 @@ ppLlvmStatement stmt =
 
 
 -- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmExpression -> Doc
+ppLlvmExpression :: LlvmExpression -> SDoc
 ppLlvmExpression expr
   = case expr of
         Alloca     tp amount        -> ppAlloca tp amount
@@ -248,7 +244,7 @@ ppLlvmExpression expr
 
 -- | Should always be a function pointer. So a global var of function type
 -- (since globals are always pointers) or a local var of pointer function type.
-ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
+ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc
 ppCall ct fptr vals attrs = case fptr of
                            --
     -- if local var function pointer, unwrap
@@ -278,13 +274,13 @@ ppCall ct fptr vals attrs = case fptr of
                     <+> rparen <+> attrDoc
 
 
-ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
+ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
 ppMachOp op left right =
   (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
         <> comma <+> (text $ getName right)
 
 
-ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
+ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
 ppCmpOp op left right =
   let cmpOp
         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
@@ -299,16 +295,16 @@ ppCmpOp op left right =
         <+> (text $ getName left) <> comma <+> (text $ getName right)
 
 
-ppAssignment :: LlvmVar -> Doc -> Doc
+ppAssignment :: LlvmVar -> SDoc -> SDoc
 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
 
-ppFence :: Bool -> LlvmSyncOrdering -> Doc
+ppFence :: Bool -> LlvmSyncOrdering -> SDoc
 ppFence st ord =
   let singleThread = case st of True  -> text "singlethread"
                                 False -> empty
   in text "fence" <+> singleThread <+> ppSyncOrdering ord
 
-ppSyncOrdering :: LlvmSyncOrdering -> Doc
+ppSyncOrdering :: LlvmSyncOrdering -> SDoc
 ppSyncOrdering SyncUnord     = text "unordered"
 ppSyncOrdering SyncMonotonic = text "monotonic"
 ppSyncOrdering SyncAcquire   = text "acquire"
@@ -316,59 +312,59 @@ ppSyncOrdering SyncRelease   = text "release"
 ppSyncOrdering SyncAcqRel    = text "acq_rel"
 ppSyncOrdering SyncSeqCst    = text "seq_cst"
 
-ppLoad :: LlvmVar -> Doc
+ppLoad :: LlvmVar -> SDoc
 ppLoad var = text "load" <+> texts var
 
 
-ppStore :: LlvmVar -> LlvmVar -> Doc
+ppStore :: LlvmVar -> LlvmVar -> SDoc
 ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
 
 
-ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
+ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
 ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
 
 
-ppMalloc :: LlvmType -> Int -> Doc
+ppMalloc :: LlvmType -> Int -> SDoc
 ppMalloc tp amount =
   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
   in text "malloc" <+> texts tp <> comma <+> texts amount'
 
 
-ppAlloca :: LlvmType -> Int -> Doc
+ppAlloca :: LlvmType -> Int -> SDoc
 ppAlloca tp amount =
   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
   in text "alloca" <+> texts tp <> comma <+> texts amount'
 
 
-ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc
+ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
 ppGetElementPtr inb ptr idx =
   let indexes = comma <+> ppCommaJoin idx
       inbound = if inb then text "inbounds" else empty
   in text "getelementptr" <+> inbound <+> texts ptr <> indexes
 
 
-ppReturn :: Maybe LlvmVar -> Doc
+ppReturn :: Maybe LlvmVar -> SDoc
 ppReturn (Just var) = text "ret" <+> texts var
 ppReturn Nothing    = text "ret" <+> texts LMVoid
 
 
-ppBranch :: LlvmVar -> Doc
+ppBranch :: LlvmVar -> SDoc
 ppBranch var = text "br" <+> texts var
 
 
-ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
+ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
 ppBranchIf cond trueT falseT
   = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
 
 
-ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
+ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
 ppPhi tp preds =
   let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
         <+> (text $ getName label)
   in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
 
 
-ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc
+ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
 ppSwitch scrut dflt targets =
   let ppTarget  (val, lab) = texts val <> comma <+> texts lab
       ppTargets  xs        = brackets $ vcat (map ppTarget xs)
@@ -376,7 +372,7 @@ ppSwitch scrut dflt targets =
         <+> ppTargets targets
 
 
-ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc
+ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
 ppAsm asm constraints rty vars sideeffect alignstack =
   let asm'  = doubleQuotes $ ftext asm
       cons  = doubleQuotes $ ftext constraints
@@ -388,15 +384,15 @@ ppAsm asm constraints rty vars sideeffect alignstack =
         <+> cons <> vars'
 
 
-ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc
+ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
 ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
 
 
-ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc
+ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc
 ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
 
 
-ppMetas :: [MetaData] -> Doc
+ppMetas :: [MetaData] -> SDoc
 ppMetas meta = hcat $ map ppMeta meta
   where
     ppMeta (name, (LMMetaUnamed n))
@@ -406,25 +402,21 @@ ppMetas meta = hcat $ map ppMeta meta
 --------------------------------------------------------------------------------
 -- * Misc functions
 --------------------------------------------------------------------------------
-ppCommaJoin :: (Show a) => [a] -> Doc
+ppCommaJoin :: (Show a) => [a] -> SDoc
 ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
 
-ppSpaceJoin :: (Show a) => [a] -> Doc
+ppSpaceJoin :: (Show a) => [a] -> SDoc
 ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
 
--- | Convert SDoc to Doc
-llvmSDoc :: Out.SDoc -> Doc
-llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
-
--- | Showable to Doc
-texts :: (Show a) => a -> Doc
+-- | Showable to SDoc
+texts :: (Show a) => a -> SDoc
 texts = (text . show)
 
 -- | Blank line.
-newLine :: Doc
+newLine :: SDoc
 newLine = text ""
 
 -- | Exclamation point.
-exclamation :: Doc
+exclamation :: SDoc
 exclamation = text "!"
 

compiler/llvmGen/LlvmCodeGen.hs

@@ -48,9 +48,9 @@ llvmCodeGen dflags h us cmms
             in (d,env')
     in do
         showPass dflags "LlVM CodeGen"
-        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader
+        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
         bufh <- newBufHandle h
-        Prt.bufLeftRender bufh $ pprLlvmHeader
+        Prt.bufLeftRender bufh $ withPprStyleDoc (mkCodeStyle CStyle) pprLlvmHeader
         ver  <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
         -- cache llvm version for later use
         writeIORef (llvmVersion dflags) ver
@@ -72,11 +72,11 @@ cmmDataLlvmGens dflags h env [] lmdata
   = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
                           resolveLlvmDatas env lmdata
         lmdoc = {-# SCC "llvm_data_ppr" #-}
-                Prt.vcat $ map pprLlvmData lmdata'
+                vcat $ map pprLlvmData lmdata'
     in do
-        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
+        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
         {-# SCC "llvm_data_out" #-}
-            Prt.bufLeftRender h lmdoc
+            Prt.bufLeftRender h $ withPprStyleDoc (mkCodeStyle CStyle) lmdoc
         return env'
 
 cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
@@ -108,6 +108,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
         lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
                   (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
     in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
+                             withPprStyleDoc (mkCodeStyle CStyle) $
                              pprLlvmData ([lmUsed], [])
 
 cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
@@ -119,7 +120,8 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar
 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
     (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
     let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
-    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
+    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
+                          withPprStyleDoc (mkCodeStyle CStyle) $ vcat docs
     cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
 
 
@@ -139,7 +141,7 @@ cmmLlvmGen dflags us env cmm = do
                                   initUs us $ genLlvmProc env fixed_cmm
 
     dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
-        (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
+        (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
 
     return (usGen, env', llvmBC)
 

compiler/llvmGen/LlvmCodeGen/Base.hs

@@ -226,7 +226,10 @@ getDflags (LlvmEnv (_, _, _, d)) = d
 -- | Pretty print a 'CLabel'.
 strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
 strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
-    (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
+    (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
+    where dflags = getDflags env
+          style = Outp.mkCodeStyle Outp.CStyle
+          toString doc = Outp.renderWithStyle dflags doc style
 
 -- | Create an external definition for a 'CLabel' defined in another module.
 genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal

compiler/llvmGen/LlvmCodeGen/CodeGen.hs

@@ -950,7 +950,10 @@ genMachOp_slow env opt op [x, y] = case op of
 
                 else do
                     -- Error. Continue anyway so we can debug the generated ll file.
-                    let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr (getLlvmPlatform env))
+                    let dflags = getDflags env
+                        style = mkCodeStyle CStyle
+                        toString doc = renderWithStyle dflags doc style
+                        cmmToStr = (lines . toString . PprCmm.pprExpr (getLlvmPlatform env))
                     let dx = Comment $ map fsLit $ cmmToStr x
                     let dy = Comment $ map fsLit $ cmmToStr y
                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy

compiler/llvmGen/LlvmCodeGen/Ppr.hs

@@ -17,8 +17,7 @@ import CLabel
 import OldCmm
 
 import FastString
-import qualified Outputable
-import Pretty
+import Outputable
 import Unique
 
 
@@ -27,7 +26,7 @@ import Unique
 --
 
 -- | Header code for LLVM modules
-pprLlvmHeader :: Doc
+pprLlvmHeader :: SDoc
 pprLlvmHeader =
     moduleLayout
     $+$ text ""
@@ -37,7 +36,7 @@ pprLlvmHeader =
 
 
 -- | LLVM module layout description for the host target
-moduleLayout :: Doc
+moduleLayout :: SDoc
 moduleLayout =
 #if i386_TARGET_ARCH
 
@@ -76,7 +75,7 @@ moduleLayout =
 
 
 -- | Pretty print LLVM data code
-pprLlvmData :: LlvmData -> Doc
+pprLlvmData :: LlvmData -> SDoc
 pprLlvmData (globals, types) =
     let tryConst (v, Just s )   = ppLlvmGlobal (v, Just s)
         tryConst g@(_, Nothing) = ppLlvmGlobal g
@@ -91,7 +90,7 @@ pprLlvmData (globals, types) =
 
 
 -- | Pretty print LLVM code
-pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (Doc, [LlvmVar])
+pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
 pprLlvmCmmDecl _ _ (CmmData _ lmdata)
   = (vcat $ map pprLlvmData lmdata, [])
 
@@ -116,7 +115,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks))
 
 
 -- | Pretty print CmmStatic
-pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar])
+pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar])
 pprInfoTable env count info_lbl stat
   = let unres = genLlvmData env (Text, stat)
         (_, (ldata, ltypes)) = resolveLlvmData env unres