LlvmCodeGen.hs 5.1 KB
Newer Older
1
2
3
4
-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--

5
module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
6
7
8

#include "HsVersions.h"

dterei's avatar
dterei committed
9
import Llvm
10
11
12
13
import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
14
15
import LlvmMangler

16
import CgUtils ( fixStgRegisters )
17
18
import OldCmm
import OldPprCmm
19
20
21
22

import BufWrite
import DynFlags
import ErrUtils
dterei's avatar
dterei committed
23
import FastString
24
25
26
import Outputable
import qualified Pretty as Prt
import UniqSupply
dterei's avatar
dterei committed
27
import Util
28
import SysTools ( figureLlvmVersion )
29

30
import Data.Maybe ( fromMaybe )
31
32
33
import System.IO

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
34
-- | Top-level of the LLVM Code generator
35
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
36
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
37
llvmCodeGen dflags h us cmms
38
  = let cmm = concat cmms
39
40
        (cdata,env) = {-# SCC "llvm_split" #-}
                      foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
41
42
        split (CmmData s d' ) (d,e) = ((s,d'):d,e)
        split (CmmProc i l _) (d,e) =
43
            let lbl = strCLabel_llvm env $ case i of
44
45
                        Nothing                   -> l
                        Just (Statics info_lbl _) -> info_lbl
46
47
                env' = funInsert lbl llvmFunTy e
            in (d,env')
48
    in do
49
        showPass dflags "LlVM CodeGen"
50
51
        bufh <- newBufHandle h
        Prt.bufLeftRender bufh $ pprLlvmHeader
52
        ver  <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
dterei's avatar
dterei committed
53
54
        env' <- {-# SCC "llvm_datas_gen" #-}
                cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
55
        {-# SCC "llvm_procs_gen" #-}
dterei's avatar
dterei committed
56
             cmmProcLlvmGens dflags bufh us env' cmm 1 []
57
58
        bFlush bufh
        return  ()
59
60
61


-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
62
-- | Do LLVM code generation on all these Cmms data sections.
63
--
64
cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
65
                -> [LlvmUnresData] -> IO ( LlvmEnv )
66

67
cmmDataLlvmGens dflags h env [] lmdata
dterei's avatar
dterei committed
68
  = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
69
                          resolveLlvmDatas env lmdata
dterei's avatar
dterei committed
70
71
        lmdoc = {-# SCC "llvm_data_ppr" #-}
                Prt.vcat $ map pprLlvmData lmdata'
72
    in do
73
        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
74
75
        {-# SCC "llvm_data_out" #-}
            Prt.bufLeftRender h lmdoc
76
77
        return env'

78
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
79
80
81
82
83
84
85
  = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
                           genLlvmData env cmm
        env' = {-# SCC "llvm_data_insert" #-}
               funInsert (strCLabel_llvm env l) ty env
        lmdata' = {-# SCC "llvm_data_append" #-}
                  lm:lmdata
    in cmmDataLlvmGens dflags h env' cmms lmdata'
86
87
88


-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
89
-- | Do LLVM code generation on all these Cmms procs.
90
--
Simon Peyton Jones's avatar
Simon Peyton Jones committed
91
cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
92
93
      -> Int         -- ^ count, used for generating unique subsections
      -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
94
95
      -> IO ()

dterei's avatar
dterei committed
96
97
cmmProcLlvmGens _ _ _ _ [] _ []
  = return ()
98

99
cmmProcLlvmGens _ h _ _ [] _ ivars
100
101
102
103
  = let ivars' = concat ivars
        cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
        ty     = (LMArray (length ivars') i8Ptr)
        usedArray = LMStaticArray (map cast ivars') ty
104
        lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
105
                  (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
106
    in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
dterei's avatar
dterei committed
107
                             pprLlvmData ([lmUsed], [])
dterei's avatar
dterei committed
108

109
110
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
 = cmmProcLlvmGens dflags h us env cmms count ivars
111

112
113
114
115
116
cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars
 = cmmProcLlvmGens dflags h us env cmms count ivars

cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
    (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
Simon Peyton Jones's avatar
Simon Peyton Jones committed
117
    let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
dterei's avatar
dterei committed
118
    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
119
    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
120
121


dterei's avatar
dterei committed
122
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
123
124
cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
            -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
125
cmmLlvmGen dflags us env cmm = do
126
    -- rewrite assignments to global regs
dterei's avatar
dterei committed
127
128
    let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
                    fixStgRegisters cmm
129
130

    dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
131
        (pprCmmGroup (targetPlatform dflags) [fixed_cmm])
132
133

    -- generate llvm code from cmm
dterei's avatar
dterei committed
134
135
    let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
                                  initUs us $ genLlvmProc env fixed_cmm
136
137

    dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
Simon Peyton Jones's avatar
Simon Peyton Jones committed
138
        (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
139
140
141

    return (usGen, env', llvmBC)