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 Code generator
  34 --
  35 llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
  36 llvmCodeGen dflags h us cmms
  37   = do
  38       bufh <- newBufHandle h
  39
  40       Prt.bufLeftRender bufh $ pprLlvmHeader
  41
  42       env' <- cmmDataLlvmGens dflags bufh env cdata []
  43       cmmProcLlvmGens dflags bufh us env' cmm 1 []
  44
  45       bFlush bufh
  46
  47       return  ()
  48   where
  49         cmm = concat $ map (\(Cmm top) -> top) cmms
  50
  51         (cdata,env) = foldr split ([],initLlvmEnv) cmm
  52
  53         split (CmmData s d'   ) (d,e) = ((s,d'):d,e)
  54         split (CmmProc i l _ _) (d,e) =
  55             let lbl = strCLabel_llvm $ if not (null i)
  56                    then entryLblToInfoLbl l
  57                    else l
  58                 env' = funInsert lbl llvmFunTy e
  59             in (d,env')
  60
  61
  62 -- -----------------------------------------------------------------------------
  63 -- | Do LLVM code generation on all these Cmms data sections.
  64 --
  65 cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])]
  66                 -> [LlvmUnresData] -> IO ( LlvmEnv )
  67
  68 cmmDataLlvmGens dflags h env [] lmdata
  69   = let (env', lmdata') = resolveLlvmDatas env lmdata []
  70         lmdoc = Prt.vcat $ map pprLlvmData lmdata'
  71     in do
  72         dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
  73         Prt.bufLeftRender h lmdoc
  74         return env'
  75
  76 cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
  77   = let lmdata'@(l, _, ty, _) = genLlvmData cmm
  78         env' = funInsert (strCLabel_llvm l) ty env
  79     in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
  80
  81
  82 -- -----------------------------------------------------------------------------
  83 -- | Do LLVM code generation on all these Cmms procs.
  84 --
  85 cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop]
  86       -> Int          -- ^ count, used for generating unique subsections
  87       -> [LlvmVar]    -- ^ info tables that need to be marked as 'used'
  88       -> IO ()
  89
  90 cmmProcLlvmGens _ _ _ _ [] _ []
  91   = return ()
  92
  93 cmmProcLlvmGens _ h _ _ [] _ ivars
  94   = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
  95         ty     = (LMArray (length ivars) i8Ptr)
  96         usedArray = LMStaticArray (map cast ivars) ty
  97         lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
  98                   (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
  99     in do
 100         Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
 101
 102 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
 103   = do
 104     (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
 105
 106     let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm
 107     Prt.bufLeftRender h $ Prt.vcat docs
 108
 109     cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
 110
 111
 112 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
 113 cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop
 114             -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] )
 115 cmmLlvmGen dflags us env cmm
 116   = do
 117     -- rewrite assignments to global regs
 118     let fixed_cmm = fixStgRegisters cmm
 119
 120     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
 121         (pprCmm $ Cmm [fixed_cmm])
 122
 123     -- generate llvm code from cmm
 124     let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
 125
 126     dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
 127         (vcat $ map (docToSDoc . fst . pprLlvmCmmTop env' 0) llvmBC)
 128
 129     return (usGen, env', llvmBC)
 130