Remove the old codegen
[ghc.git] / compiler / llvmGen / LlvmCodeGen / Base.hs
index ba74a7f..86fab77 100644 (file)
@@ -6,11 +6,15 @@
 
 module LlvmCodeGen.Base (
 
 
 module LlvmCodeGen.Base (
 
-        LlvmCmmTop, LlvmBasicBlock,
+        LlvmCmmDecl, LlvmBasicBlock,
         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
 
         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
 
+        LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
+        maxSupportLlvmVersion,
+
         LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
         LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
-        funLookup, funInsert,
+        funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
+        getDflags, ghcInternalFunctions,
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
@@ -25,24 +29,25 @@ module LlvmCodeGen.Base (
 import Llvm
 import LlvmCodeGen.Regs
 
 import Llvm
 import LlvmCodeGen.Regs
 
-import CgUtils ( activeStgRegs )
 import CLabel
 import CLabel
-import Cmm
-
+import CodeGen.Platform ( activeStgRegs )
+import DynFlags
 import FastString
 import FastString
+import OldCmm
 import qualified Outputable as Outp
 import qualified Outputable as Outp
-import Unique
+import Platform
 import UniqFM
 import UniqFM
+import Unique
 
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
 --
 
 
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
 --
 
-type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement)
+type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
 type LlvmBasicBlock = GenBasicBlock LlvmStatement
 
 -- | Unresolved code.
 type LlvmBasicBlock = GenBasicBlock LlvmStatement
 
 -- | Unresolved code.
--- Of the form: (data label, data type, unresovled data)
+-- Of the form: (data label, data type, unresolved data)
 type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
 
 -- | Top level LLVM Data (globals and type aliases)
 type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
 
 -- | Top level LLVM Data (globals and type aliases)
@@ -77,43 +82,49 @@ widthToLlvmInt :: Width -> LlvmType
 widthToLlvmInt w = LMInt $ widthInBits w
 
 -- | GHC Call Convention for LLVM
 widthToLlvmInt w = LMInt $ widthInBits w
 
 -- | GHC Call Convention for LLVM
-llvmGhcCC :: LlvmCallConvention
-llvmGhcCC = CC_Ncc 10
+llvmGhcCC :: DynFlags -> LlvmCallConvention
+llvmGhcCC dflags
+ | platformUnregisterised (targetPlatform dflags) = CC_Ccc
+ | otherwise                                      = CC_Ncc 10
 
 -- | Llvm Function type for Cmm function
 
 -- | Llvm Function type for Cmm function
-llvmFunTy :: LlvmType
-llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible
+llvmFunTy :: DynFlags -> LlvmType
+llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible
 
 -- | Llvm Function signature
 
 -- | Llvm Function signature
-llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link
+llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig env lbl link
+    = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link
 
 
-llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig' lbl link
+llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig' dflags lbl link
   = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                    | otherwise   = (x, [])
   = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                    | otherwise   = (x, [])
-    in LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
-                        (map (toParams . getVarType) llvmFunArgs) llvmFunAlign
+    in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+                        (map (toParams . getVarType) (llvmFunArgs dflags))
+                        (llvmFunAlign dflags)
 
 -- | Create a Haskell function in LLVM.
 
 -- | Create a Haskell function in LLVM.
-mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
+mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
            -> LlvmFunction
            -> LlvmFunction
-mkLlvmFunc lbl link sec blks
-  = let funDec = llvmFunSig lbl link
-        funArgs = map (fsLit . getPlainName) llvmFunArgs
+mkLlvmFunc env lbl link sec blks
+  = let dflags = getDflags env
+        funDec = llvmFunSig env lbl link
+        funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags)
     in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
 
 -- | Alignment to use for functions
     in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
 
 -- | Alignment to use for functions
-llvmFunAlign :: LMAlign
-llvmFunAlign = Just 4
+llvmFunAlign :: DynFlags -> LMAlign
+llvmFunAlign dflags = Just (wORD_SIZE dflags)
 
 -- | Alignment to use for into tables
 
 -- | Alignment to use for into tables
-llvmInfAlign :: LMAlign
-llvmInfAlign = Just 4
+llvmInfAlign :: DynFlags -> LMAlign
+llvmInfAlign dflags = Just (wORD_SIZE dflags)
 
 -- | A Function's arguments
 
 -- | A Function's arguments
-llvmFunArgs :: [LlvmVar]
-llvmFunArgs = map lmGlobalRegArg activeStgRegs
+llvmFunArgs :: DynFlags -> [LlvmVar]
+llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform)
+    where platform = targetPlatform dflags
 
 -- | Llvm standard fun attributes
 llvmStdFunAttrs :: [LlvmFuncAttr]
 
 -- | Llvm standard fun attributes
 llvmStdFunAttrs :: [LlvmFuncAttr]
@@ -125,56 +136,121 @@ tysToParams :: [LlvmType] -> [LlvmParameter]
 tysToParams = map (\ty -> (ty, []))
 
 -- | Pointer width
 tysToParams = map (\ty -> (ty, []))
 
 -- | Pointer width
-llvmPtrBits :: Int
-llvmPtrBits = widthInBits $ typeWidth gcWord
+llvmPtrBits :: DynFlags -> Int
+llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
+
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- | LLVM Version Number
+type LlvmVersion = Int
+
+-- | The LLVM Version we assume if we don't know
+defaultLlvmVersion :: LlvmVersion
+defaultLlvmVersion = 30
+
+minSupportLlvmVersion :: LlvmVersion
+minSupportLlvmVersion = 28
 
 
+maxSupportLlvmVersion :: LlvmVersion
+maxSupportLlvmVersion = 31
 
 -- ----------------------------------------------------------------------------
 -- * Environment Handling
 --
 
 
 -- ----------------------------------------------------------------------------
 -- * Environment Handling
 --
 
-type LlvmEnvMap = UniqFM LlvmType
 -- two maps, one for functions and one for local vars.
 -- two maps, one for functions and one for local vars.
-type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
+newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
+
+type LlvmEnvMap = UniqFM LlvmType
 
 -- | Get initial Llvm environment.
 
 -- | Get initial Llvm environment.
-initLlvmEnv :: LlvmEnv
-initLlvmEnv = (emptyUFM, emptyUFM)
+initLlvmEnv :: DynFlags -> LlvmEnv
+initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
+    where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ]
+
+-- | Here we pre-initialise some functions that are used internally by GHC
+-- so as to make sure they have the most general type in the case that
+-- user code also uses these functions but with a different type than GHC
+-- internally. (Main offender is treating return type as 'void' instead of
+-- 'void *'. Fixes trac #5486.
+ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)]
+ghcInternalFunctions dflags =
+    [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
+    , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
+    ]
+  where
+    mk n ret args =
+        let n' = fsLit n
+        in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
+                                 FixedArgs (tysToParams args) Nothing)
 
 -- | Clear variables from the environment.
 clearVars :: LlvmEnv -> LlvmEnv
 
 -- | Clear variables from the environment.
 clearVars :: LlvmEnv -> LlvmEnv
-clearVars (e1, _) = (e1, emptyUFM)
+clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
+    LlvmEnv (e1, emptyUFM, n, p)
+
+-- | Insert local variables into the environment.
+varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
+varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
+    LlvmEnv (e1, addToUFM e2 s t, n, p)
 
 -- | Insert functions into the environment.
 
 -- | Insert functions into the environment.
-varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
-funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
+funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
+funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
+    LlvmEnv (addToUFM e1 s t, e2, n, p)
+
+-- | Lookup local variables in the environment.
+varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
+varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
+    lookupUFM e2 s
 
 -- | Lookup functions in the environment.
 
 -- | Lookup functions in the environment.
-varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-varLookup s (_, e2) = lookupUFM e2 s
-funLookup s (e1, _) = lookupUFM e1 s
+funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
+funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
+    lookupUFM e1 s
 
 
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmEnv -> LlvmVersion
+getLlvmVer (LlvmEnv (_, _, n, _)) = n
+
+-- | Set the LLVM version we are generating code for
+setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
+setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
+
+-- | Get the platform we are generating code for
+getLlvmPlatform :: LlvmEnv -> Platform
+getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
+
+-- | Get the DynFlags for this compilation pass
+getDflags :: LlvmEnv -> DynFlags
+getDflags (LlvmEnv (_, _, _, d)) = d
 
 -- ----------------------------------------------------------------------------
 -- * Label handling
 --
 
 -- | Pretty print a 'CLabel'.
 
 -- ----------------------------------------------------------------------------
 -- * Label handling
 --
 
 -- | Pretty print a 'CLabel'.
-strCLabel_llvm :: CLabel -> LMString
-strCLabel_llvm l = (fsLit . show . llvmSDoc . pprCLabel) l
+strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
+strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
+    (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
+    where dflags = getDflags env
+          style = Outp.mkCodeStyle Outp.CStyle
+          toString doc = Outp.renderWithStyle dflags doc style
 
 -- | Create an external definition for a 'CLabel' defined in another module.
 
 -- | Create an external definition for a 'CLabel' defined in another module.
-genCmmLabelRef :: CLabel -> LMGlobal
-genCmmLabelRef = genStringLabelRef . strCLabel_llvm
+genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
+genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env
 
 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
 
 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
-genStringLabelRef :: LMString -> LMGlobal
-genStringLabelRef cl
-  = let ty = LMPointer $ LMArray 0 llvmWord
+genStringLabelRef :: DynFlags -> LMString -> LMGlobal
+genStringLabelRef dflags cl
+  = let ty = LMPointer $ LMArray 0 (llvmWord dflags)
     in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
 
     in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
 
-
 -- ----------------------------------------------------------------------------
 -- * Misc
 --
 -- ----------------------------------------------------------------------------
 -- * Misc
 --