[commit: ghc] ghc-7.4: llvmGen: Use new fence instruction (102a538)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.4

http://hackage.haskell.org/trac/ghc/changeset/102a5380574ed22eca32f8e63cae22f013153f0b

>---------------------------------------------------------------

commit 102a5380574ed22eca32f8e63cae22f013153f0b
Author: Ben Gamari <ben at panda.(none)>
Date:   Tue Jan 24 19:56:35 2012 -0500

    llvmGen: Use new fence instruction
    
    Signed-off-by: David Terei <davidterei at gmail.com>
    
    MERGED from commit 766da942097613fed56417e3e149997812f83105

>---------------------------------------------------------------

 compiler/llvmGen/Llvm.hs                |    3 +++
 compiler/llvmGen/Llvm/AbsSyn.hs         |   10 ++++++++++
 compiler/llvmGen/Llvm/PpLlvm.hs         |   12 ++++++++++++
 compiler/llvmGen/LlvmCodeGen/CodeGen.hs |   26 +++++++++++++++++---------
 4 files changed, 42 insertions(+), 9 deletions(-)

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index aec492e..d516dab 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -20,6 +20,9 @@ module Llvm (
         LlvmBlocks, LlvmBlock(..), LlvmBlockId,
         LlvmParamAttr(..), LlvmParameter,
 
+        -- * Fence synchronization
+        LlvmSyncOrdering(..),
+
         -- * Call Handling
         LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
         LlvmLinkageType(..), LlvmFuncAttr(..),
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 93bc62c..468b7e4 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -61,6 +61,11 @@ data LlvmFunction = LlvmFunction {
 
 type LlvmFunctions  = [LlvmFunction]
 
+data LlvmSyncOrdering = SyncAcquire
+                      | SyncRelease
+                      | SyncAcqRel
+                      | SyncSeqCst
+                      deriving (Show, Eq)
 
 -- | Llvm Statements
 data LlvmStatement
@@ -72,6 +77,11 @@ data LlvmStatement
   = Assignment LlvmVar LlvmExpression
 
   {- |
+    Memory fence operation
+  -}
+  | Fence Bool LlvmSyncOrdering
+
+  {- |
     Always branch to the target label
   -}
   | Branch LlvmVar
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 217d02d..f3c8342 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -166,6 +166,7 @@ ppLlvmStatement :: LlvmStatement -> Doc
 ppLlvmStatement stmt
   = case stmt of
         Assignment  dst expr      -> ppAssignment dst (ppLlvmExpression expr)
+        Fence       st ord	  -> ppFence st ord
         Branch      target        -> ppBranch target
         BranchIf    cond ifT ifF  -> ppBranchIf cond ifT ifF
         Comment     comments      -> ppLlvmComments comments
@@ -254,6 +255,17 @@ ppCmpOp op left right =
 ppAssignment :: LlvmVar -> Doc -> Doc
 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
 
+ppFence :: Bool -> LlvmSyncOrdering -> Doc
+ppFence st ord =
+  let singleThread = case st of True  -> text "singlethread"
+				False -> empty
+  in text "fence" <+> singleThread <+> ppSyncOrdering ord
+
+ppSyncOrdering :: LlvmSyncOrdering -> Doc
+ppSyncOrdering SyncAcquire = text "acquire"
+ppSyncOrdering SyncRelease = text "release"
+ppSyncOrdering SyncAcqRel  = text "acq_rel"
+ppSyncOrdering SyncSeqCst  = text "seq_cst"
 
 ppLoad :: LlvmVar -> Doc
 ppLoad var = text "load" <+> texts var
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index d8507ab..c505cc0 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -136,16 +136,13 @@ stmtToInstrs env stmt = case stmt of
         -> return (env, unitOL $ Return Nothing, [])
 
 
--- | Foreign Calls
-genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
-              -> CmmReturnInfo -> UniqSM StmtData
+barrier :: LlvmEnv -> UniqSM StmtData
+barrier env = do
+    let s = Fence False SyncAcqRel
+    return (env, unitOL s, [])
 
--- Write barrier needs to be handled specially as it is implemented as an LLVM
--- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier) _ _ _
- | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
-    = return (env, nilOL, [])
- | otherwise = do
+oldBarrier :: LlvmEnv -> UniqSM StmtData
+oldBarrier env = do
     let fname = fsLit "llvm.memory.barrier"
     let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
                     FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
@@ -166,6 +163,17 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _
         lmTrue :: LlvmVar
         lmTrue  = mkIntLit i1 (-1)
 
+-- | Foreign Calls
+genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
+              -> CmmReturnInfo -> UniqSM StmtData
+
+-- Write barrier needs to be handled specially as it is implemented as an LLVM
+-- intrinsic function.
+genCall env (CmmPrim MO_WriteBarrier) _ _ _
+ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
+    = return (env, nilOL, [])
+ | otherwise = barrier env
+
 -- Handle popcnt function specifically since GHC only really has i32 and i64
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM