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
   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 Cmm
  17
  18 import FastString
  19 import Pretty
  20 import Unique
  21 import Util
  22
  23 -- ----------------------------------------------------------------------------
  24 -- * Top level
  25 --
  26
  27 -- | LLVM module layout description for the host target
  28 moduleLayout :: Doc
  29 moduleLayout =
  30 #if i386_TARGET_ARCH
  31
  32 #if darwin_TARGET_OS
  33     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\""
  34     $+$ text "target triple = \"i386-apple-darwin9.8\""
  35 #elif mingw32_TARGET_OS
  36     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\""
  37     $+$ text "target triple = \"i686-pc-win32\""
  38 #else /* Linux */
  39     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\""
  40     $+$ text "target triple = \"i386-pc-linux-gnu\""
  41 #endif
  42
  43 #elif x86_64_TARGET_ARCH
  44
  45 #if darwin_TARGET_OS
  46     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\""
  47     $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
  48 #else /* Linux */
  49     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\""
  50     $+$ text "target triple = \"x86_64-linux-gnu\""
  51 #endif
  52
  53 #else /* Not x86 */
  54     -- FIX: Other targets
  55     empty
  56 #endif
  57
  58
  59 -- | Header code for LLVM modules
  60 pprLlvmHeader :: Doc
  61 pprLlvmHeader = moduleLayout
  62
  63
  64 -- | Pretty print LLVM data code
  65 pprLlvmData :: LlvmData -> Doc
  66 pprLlvmData (globals, types) =
  67     let tryConst (v, Just s )   = ppLlvmGlobal (v, Just s)
  68         tryConst g@(_, Nothing) = ppLlvmGlobal g
  69
  70         types'   = ppLlvmTypes types
  71         globals' = vcat $ map tryConst globals
  72     in types' $+$ globals'
  73
  74
  75 -- | Pretty print LLVM code
  76 pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
  77 pprLlvmCmmTop _ _ (CmmData _ lmdata)
  78   = (vcat $ map pprLlvmData lmdata, [])
  79
  80 pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
  81   = let static = CmmDataLabel lbl : info
  82         (idoc, ivar) = if not (null info)
  83                           then pprCmmStatic env count static
  84                           else (empty, [])
  85     in (idoc $+$ (
  86         let sec = mkLayoutSection (count + 1)
  87             (lbl',sec') = if not (null info)
  88                             then (entryLblToInfoLbl lbl, sec)
  89                             else (lbl, Nothing)
  90             link = if externallyVisibleCLabel lbl'
  91                       then ExternallyVisible
  92                       else Internal
  93             funDec = llvmFunSig lbl' link
  94             lmblocks = map (\(BasicBlock id stmts) ->
  95                                 LlvmBlock (getUnique id) stmts) blks
  96             fun = LlvmFunction funDec [NoUnwind] sec' lmblocks
  97         in ppLlvmFunction fun
  98     ), ivar)
  99
 100
 101 -- | Pretty print CmmStatic
 102 pprCmmStatic :: LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
 103 pprCmmStatic env count stat
 104   = let unres = genLlvmData (Text, stat)
 105         (_, (ldata, ltypes)) = resolveLlvmData env unres
 106
 107         setSection (gv@(LMGlobalVar s ty l _ _ c), d)
 108             = let v = if l == Internal then [gv] else []
 109                   sec = mkLayoutSection count
 110               in ((LMGlobalVar s ty l sec llvmInfAlign c, d), v)
 111         setSection v = (v,[])
 112
 113         (ldata', llvmUsed) = mapAndUnzip setSection ldata
 114     in (pprLlvmData (ldata', ltypes), concat llvmUsed)
 115
 116
 117 -- | Create an appropriate section declaration for subsection <n> of text
 118 -- WARNING: This technique could fail as gas documentation says it only
 119 -- supports up to 8192 subsections per section. Inspection of the source
 120 -- code and some test programs seem to suggest it supports more than this
 121 -- so we are hoping it does.
 122 mkLayoutSection :: Int -> LMSection
 123 mkLayoutSection n
 124   = Just (fsLit $ ".text;.text " ++ show n ++ " #")
 125