compiler/llvmGen/LlvmCodeGen.hs

   1 -- -----------------------------------------------------------------------------
   2 -- | This is the top-level module in the LLVM code generator.
   3 --
   4
   5 module LlvmCodeGen ( llvmCodeGen ) where
   6
   7 #include "HsVersions.h"
   8
   9 import Llvm
  10
  11 import LlvmCodeGen.Base
  12 import LlvmCodeGen.CodeGen
  13 import LlvmCodeGen.Data
  14 import LlvmCodeGen.Ppr
  15
  16 import CLabel
  17 import Cmm
  18 import CgUtils ( fixStgRegisters )
  19 import PprCmm
  20
  21 import BufWrite
  22 import DynFlags
  23 import ErrUtils
  24 import FastString
  25 import Outputable
  26 import qualified Pretty as Prt
  27 import UniqSupply
  28 import Util
  29
  30 import System.IO
  31
  32 -- -----------------------------------------------------------------------------
  33 -- | Top-level of the llvm codegen
  34 --
  35 llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
  36 llvmCodeGen dflags h us cmms
  37   = do
  38       let cmm = concat $ map (\(Cmm top) -> top) cmms
  39
  40       bufh <- newBufHandle h
  41
  42       Prt.bufLeftRender bufh $ pprLlvmHeader
  43
  44       env <- cmmDataLlvmGens dflags bufh cmm
  45       cmmProcLlvmGens dflags bufh us env cmm 1 []
  46
  47       bFlush bufh
  48
  49       return  ()
  50
  51
  52 -- -----------------------------------------------------------------------------
  53 -- | Do llvm code generation on all these cmms data sections.
  54 --
  55 cmmDataLlvmGens
  56       :: DynFlags
  57       -> BufHandle
  58       -> [RawCmmTop]
  59       -> IO ( LlvmEnv )
  60
  61 cmmDataLlvmGens _ _ []
  62   = return ( initLlvmEnv )
  63
  64 cmmDataLlvmGens dflags h cmm =
  65     let exData (CmmData s d) = [(s,d)]
  66         exData  _            = []
  67
  68         exProclbl (CmmProc i l _ _)
  69                 | not (null i) = [strCLabel_llvm $ entryLblToInfoLbl l]
  70         exProclbl (CmmProc _ l _ _) | otherwise = [strCLabel_llvm l]
  71         exProclbl _                             = []
  72
  73         cproc = concat $ map exProclbl cmm
  74         cdata = concat $ map exData cmm
  75         env = foldl (\e l -> funInsert l llvmFunTy e) initLlvmEnv cproc
  76     in cmmDataLlvmGens' dflags h env cdata []
  77
  78 cmmDataLlvmGens'
  79       :: DynFlags
  80       -> BufHandle
  81       -> LlvmEnv
  82       -> [(Section, [CmmStatic])]
  83       -> [LlvmUnresData]
  84       -> IO ( LlvmEnv )
  85
  86 cmmDataLlvmGens' dflags h env [] lmdata
  87     = do
  88         let (env', lmdata') = resolveLlvmDatas dflags env lmdata []
  89         let lmdoc = Prt.vcat $ map (pprLlvmData dflags) lmdata'
  90
  91         dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
  92
  93         Prt.bufLeftRender h lmdoc
  94         return env'
  95
  96 cmmDataLlvmGens' dflags h env (cmm:cmms) lmdata
  97     = do
  98         let lmdata'@(l, ty, _) = genLlvmData dflags cmm
  99         let env' = funInsert (strCLabel_llvm l) ty env
 100         cmmDataLlvmGens' dflags h env' cmms (lmdata ++ [lmdata'])
 101
 102
 103 -- -----------------------------------------------------------------------------
 104 -- | Do llvm code generation on all these cmms procs.
 105 --
 106 cmmProcLlvmGens
 107       :: DynFlags
 108       -> BufHandle
 109       -> UniqSupply
 110       -> LlvmEnv
 111       -> [RawCmmTop]
 112       -> Int          -- ^ count, used for generating unique subsections
 113       -> [LlvmVar]    -- ^ info tables that need to be marked as 'used'
 114       -> IO ()
 115
 116 cmmProcLlvmGens _ _ _ _ [] _ []
 117   = return ()
 118
 119 cmmProcLlvmGens dflags h _ _ [] _ ivars
 120   = do
 121       let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
 122       let ty = (LMArray (length ivars) i8Ptr)
 123       let usedArray = LMStaticArray (map cast ivars) ty
 124       let lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
 125                       (Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
 126       Prt.bufLeftRender h $ pprLlvmData dflags ([lmUsed], [])
 127
 128 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
 129   = do
 130       (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
 131
 132       let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop dflags env' count) llvm
 133       Prt.bufLeftRender h $ Prt.vcat docs
 134
 135       cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
 136
 137
 138 -- | Complete llvm code generation phase for a single top-level chunk of Cmm.
 139 cmmLlvmGen
 140       :: DynFlags
 141       -> UniqSupply
 142       -> LlvmEnv
 143       -> RawCmmTop              -- ^ the cmm to generate code for
 144       -> IO ( UniqSupply,
 145               LlvmEnv,
 146               [LlvmCmmTop] )   -- llvm code
 147
 148 cmmLlvmGen dflags us env cmm
 149   = do
 150     -- rewrite assignments to global regs
 151     let fixed_cmm = fixStgRegisters cmm
 152
 153     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
 154         (pprCmm $ Cmm [fixed_cmm])
 155
 156     -- generate llvm code from cmm
 157     let ((env', llvmBC), usGen) = initUs us $ genLlvmCode dflags env fixed_cmm
 158
 159     dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
 160         (vcat $ map (docToSDoc . fst . pprLlvmCmmTop dflags env' 0) llvmBC)
 161
 162     return (usGen, env', llvmBC)
 163
 164
 165 -- -----------------------------------------------------------------------------
 166 -- | Instruction selection
 167 --
 168 genLlvmCode
 169     :: DynFlags
 170     -> LlvmEnv
 171     -> RawCmmTop
 172     -> UniqSM (LlvmEnv, [LlvmCmmTop])
 173
 174 genLlvmCode _ env (CmmData _ _)
 175     = return (env, [])
 176
 177 genLlvmCode _ env (CmmProc _ _ _ (ListGraph []))
 178     = return (env, [])
 179
 180 genLlvmCode _ env cp@(CmmProc _ _ _ _)
 181     = genLlvmProc env cp
 182