Implement function-sections for Haskell code, #8405
[ghc.git] / compiler / llvmGen / LlvmCodeGen / Ppr.hs
1 {-# LANGUAGE CPP #-}
2
3 -- ----------------------------------------------------------------------------
4 -- | Pretty print helpers for the LLVM Code generator.
5 --
6 module LlvmCodeGen.Ppr (
7 pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection
8 ) where
9
10 #include "HsVersions.h"
11
12 import Llvm
13 import LlvmCodeGen.Base
14 import LlvmCodeGen.Data
15
16 import CLabel
17 import Cmm
18 import Platform
19
20 import FastString
21 import Outputable
22 import Unique
23
24
25 -- ----------------------------------------------------------------------------
26 -- * Top level
27 --
28
29 -- | Header code for LLVM modules
30 pprLlvmHeader :: SDoc
31 pprLlvmHeader = moduleLayout
32
33
34 -- | LLVM module layout description for the host target
35 moduleLayout :: SDoc
36 moduleLayout = sdocWithPlatform $ \platform ->
37 case platform of
38 Platform { platformArch = ArchX86, platformOS = OSDarwin } ->
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:128:128-n8:16:32\""
40 $+$ text "target triple = \"i386-apple-darwin9.8\""
41 Platform { platformArch = ArchX86, platformOS = OSMinGW32 } ->
42 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\""
43 $+$ text "target triple = \"i686-pc-win32\""
44 Platform { platformArch = ArchX86, platformOS = OSLinux } ->
45 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\""
46 $+$ text "target triple = \"i386-pc-linux-gnu\""
47 Platform { platformArch = ArchX86_64, platformOS = OSDarwin } ->
48 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\""
49 $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
50 Platform { platformArch = ArchX86_64, platformOS = OSLinux } ->
51 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\""
52 $+$ text "target triple = \"x86_64-linux-gnu\""
53 Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
54 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-v64:64:64-v128:64:128-a0:0:64-n32\""
55 $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\""
56 Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
57 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-v64:64:64-v128:64:128-a0:0:64-n32\""
58 $+$ text "target triple = \"arm-unknown-linux-androideabi\""
59 Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } ->
60 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-v64:64:64-v128:64:128-a0:0:64-n32\""
61 $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\""
62 Platform { platformArch = ArchARM {}, platformOS = OSiOS } ->
63 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-v64:64:64-v128:64:128-a0:0:64-n32\""
64 $+$ text "target triple = \"arm-apple-darwin10\""
65 Platform { platformArch = ArchX86, platformOS = OSiOS } ->
66 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\""
67 $+$ text "target triple = \"i386-apple-darwin11\""
68 Platform { platformArch = ArchARM64, platformOS = OSiOS } ->
69 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-n32:64-S128\""
70 $+$ text "target triple = \"arm64-apple-ios7.0.0\""
71 Platform { platformArch = ArchARM64, platformOS = OSLinux } ->
72 text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\""
73 $+$ text "target triple = \"aarch64-unknown-linux-gnu\""
74 _ ->
75 if platformIsCrossCompiling platform
76 then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info."
77 else empty
78 -- If you see the above panic, GHC is missing the required target datalayout
79 -- and triple information. You can obtain this info by compiling a simple
80 -- 'hello world' C program with the clang C compiler eg:
81 -- clang hello.c -emit-llvm -o hello.ll
82 -- and the first two lines of hello.ll should provide the 'target datalayout'
83 -- and 'target triple' lines required.
84
85
86 -- | Pretty print LLVM data code
87 pprLlvmData :: LlvmData -> SDoc
88 pprLlvmData (globals, types) =
89 let ppLlvmTys (LMAlias a) = ppLlvmAlias a
90 ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
91 ppLlvmTys _other = empty
92
93 types' = vcat $ map ppLlvmTys types
94 globals' = ppLlvmGlobals globals
95 in types' $+$ globals'
96
97
98 -- | Pretty print LLVM code
99 pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
100 pprLlvmCmmDecl (CmmData _ lmdata)
101 = return (vcat $ map pprLlvmData lmdata, [])
102
103 pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
104 = do let lbl = case mb_info of
105 Nothing -> entry_lbl
106 Just (Statics info_lbl _) -> info_lbl
107 link = if externallyVisibleCLabel lbl
108 then ExternallyVisible
109 else Internal
110 lmblocks = map (\(BasicBlock id stmts) ->
111 LlvmBlock (getUnique id) stmts) blks
112
113 funDec <- llvmFunSig live lbl link
114 dflags <- getDynFlags
115 let buildArg = fsLit . showSDoc dflags . ppPlainName
116 funArgs = map buildArg (llvmFunArgs dflags live)
117 funSect = llvmFunSection dflags (decName funDec)
118
119 -- generate the info table
120 prefix <- case mb_info of
121 Nothing -> return Nothing
122 Just (Statics _ statics) -> do
123 infoStatics <- mapM genData statics
124 let infoTy = LMStruct $ map getStatType infoStatics
125 return $ Just $ LMStaticStruc infoStatics infoTy
126
127
128 let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
129 prefix lmblocks
130 name = decName $ funcDecl fun
131 defName = name `appendFS` fsLit "$def"
132 funcDecl' = (funcDecl fun) { decName = defName }
133 fun' = fun { funcDecl = funcDecl' }
134 funTy = LMFunction funcDecl'
135 funVar = LMGlobalVar name
136 (LMPointer funTy)
137 link
138 Nothing
139 Nothing
140 Alias
141 defVar = LMGlobalVar defName
142 (LMPointer funTy)
143 (funcLinkage funcDecl')
144 (funcSect fun)
145 (funcAlign funcDecl')
146 Alias
147 alias = LMGlobal funVar
148 (Just $ LMBitc (LMStaticPointer defVar)
149 (LMPointer $ LMInt 8))
150
151 return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
152
153
154 -- | The section we are putting info tables and their entry code into, should
155 -- be unique since we process the assembly pattern matching this.
156 infoSection :: String
157 infoSection = "X98A__STRIP,__me"