compiler/llvmGen/LlvmCodeGen/Ppr.hs

   1 -- ----------------------------------------------------------------------------
   2 -- | Pretty print helpers for the LLVM Code generator.
   3 --
   4
   5 module LlvmCodeGen.Ppr (
   6         pprLlvmHeader, pprLlvmCmmTop, pprLlvmData, infoSection, iTableSuf
   7     ) where
   8
   9 #include "HsVersions.h"
  10
  11 import Llvm
  12 import LlvmCodeGen.Base
  13 import LlvmCodeGen.Data
  14
  15 import CLabel
  16 import OldCmm
  17
  18 import FastString
  19 import qualified Outputable
  20 import Pretty
  21 import Unique
  22
  23
  24 -- ----------------------------------------------------------------------------
  25 -- * Top level
  26 --
  27
  28 -- | LLVM module layout description for the host target
  29 moduleLayout :: Doc
  30 moduleLayout =
  31 #if i386_TARGET_ARCH
  32
  33 #if darwin_TARGET_OS
  34     text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""
  35     $+$ text "target triple = \"i386-apple-darwin9.8\""
  36 #elif mingw32_TARGET_OS
  37     text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
  38     $+$ text "target triple = \"i686-pc-win32\""
  39 #else /* Linux */
  40     text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
  41     $+$ text "target triple = \"i386-pc-linux-gnu\""
  42 #endif
  43
  44 #elif x86_64_TARGET_ARCH
  45
  46 #if darwin_TARGET_OS
  47     text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
  48     $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
  49 #else /* Linux */
  50     text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
  51     $+$ text "target triple = \"x86_64-linux-gnu\""
  52 #endif
  53
  54 #else /* Not x86 */
  55     -- FIX: Other targets
  56     empty
  57 #endif
  58
  59
  60 -- | Header code for LLVM modules
  61 pprLlvmHeader :: Doc
  62 pprLlvmHeader = moduleLayout
  63
  64
  65 -- | Pretty print LLVM data code
  66 pprLlvmData :: LlvmData -> Doc
  67 pprLlvmData (globals, types) =
  68     let tryConst (v, Just s )   = ppLlvmGlobal (v, Just s)
  69         tryConst g@(_, Nothing) = ppLlvmGlobal g
  70
  71         ppLlvmTys (LMAlias    a) = ppLlvmAlias a
  72         ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
  73         ppLlvmTys _other         = empty
  74
  75         types'   = vcat $ map ppLlvmTys types
  76         globals' = vcat $ map tryConst globals
  77     in types' $+$ globals'
  78
  79
  80 -- | Pretty print LLVM code
  81 pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
  82 pprLlvmCmmTop _ _ (CmmData _ lmdata)
  83   = (vcat $ map pprLlvmData lmdata, [])
  84
  85 pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks))
  86   = let static = CmmDataLabel lbl : info
  87         (idoc, ivar) = if not (null info)
  88                           then pprInfoTable env count lbl static
  89                           else (empty, [])
  90     in (idoc $+$ (
  91         let sec = mkLayoutSection (count + 1)
  92             (lbl',sec') = if not (null info)
  93                             then (entryLblToInfoLbl lbl, sec)
  94                             else (lbl, Nothing)
  95             link = if externallyVisibleCLabel lbl'
  96                       then ExternallyVisible
  97                       else Internal
  98             lmblocks = map (\(BasicBlock id stmts) ->
  99                                 LlvmBlock (getUnique id) stmts) blks
 100             fun = mkLlvmFunc lbl' link  sec' lmblocks
 101         in ppLlvmFunction fun
 102     ), ivar)
 103
 104
 105 -- | Pretty print CmmStatic
 106 pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar])
 107 pprInfoTable env count lbl stat
 108   = let unres = genLlvmData (Text, stat)
 109         (_, (ldata, ltypes)) = resolveLlvmData env unres
 110
 111         setSection ((LMGlobalVar _ ty l _ _ c), d)
 112             = let sec = mkLayoutSection count
 113                   ilabel = strCLabel_llvm (entryLblToInfoLbl lbl)
 114                               `appendFS` fsLit iTableSuf
 115                   gv = LMGlobalVar ilabel ty l sec llvmInfAlign c
 116                   v = if l == Internal then [gv] else []
 117               in ((gv, d), v)
 118         setSection v = (v,[])
 119
 120         (ldata', llvmUsed) = setSection (last ldata)
 121     in if length ldata /= 1
 122           then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
 123           else (pprLlvmData ([ldata'], ltypes), llvmUsed)
 124
 125
 126 -- | We generate labels for info tables by converting them to the same label
 127 -- as for the entry code but adding this string as a suffix.
 128 iTableSuf :: String
 129 iTableSuf = "_itable"
 130
 131
 132 -- | Create a specially crafted section declaration that encodes the order this
 133 -- section should be in the final object code.
 134 --
 135 -- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses
 136 -- this section declaration to do its processing.
 137 mkLayoutSection :: Int -> LMSection
 138 mkLayoutSection n
 139   = Just (fsLit $ infoSection ++ show n)
 140
 141
 142 -- | The section we are putting info tables and their entry code into, should
 143 -- be unique since we process the assembly pattern matching this.
 144 infoSection :: String
 145 infoSection = "X98A__STRIP,__me"
 146