X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen%2FCodeGen.hs;h=f5dd3bbf830f2c7dbdf348a1447d0a10ff17ff77;hb=6f66d02c9654fc037db0582857acdcc15e0fd1d3;hp=3eb873ea50bc1d1fa4f64d02153662abc8fc5bdc;hpb=e94570ba7c84444f034b8d552c05f8594532b329;p=ghc-hetmet.git

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 3eb873e..f5dd3bb 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -13,8 +13,8 @@ import LlvmCodeGen.Regs
 import BlockId
 import CgUtils ( activeStgRegs, callerSaves )
 import CLabel
-import Cmm
-import qualified PprCmm
+import OldCmm
+import qualified OldPprCmm as PprCmm
 import OrdList
 
 import BasicTypes
@@ -26,10 +26,12 @@ import UniqSupply
 import Unique
 import Util
 
+import Data.List ( partition )
 import Control.Monad ( liftM )
 
 type LlvmStatements = OrdList LlvmStatement
 
+
 -- -----------------------------------------------------------------------------
 -- | Top-level of the LLVM proc Code generator
 --
@@ -37,14 +39,14 @@ genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
 genLlvmProc env (CmmData _ _)
   = return (env, [])
 
-genLlvmProc env (CmmProc _ _ _ (ListGraph []))
+genLlvmProc env (CmmProc _ _ (ListGraph []))
   = return (env, [])
 
-genLlvmProc env (CmmProc info lbl params (ListGraph blocks))
+genLlvmProc env (CmmProc info lbl (ListGraph blocks))
   = do
         (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
 
-        let proc    = CmmProc info lbl params (ListGraph lmblocks)
+        let proc    = CmmProc info lbl (ListGraph lmblocks)
         let tops    = lmdata ++ [proc]
 
         return (env', tops)
@@ -62,9 +64,9 @@ basicBlocksCodeGen :: LlvmEnv
 basicBlocksCodeGen env ([]) (blocks, tops)
   = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
        let allocs' = concat allocs
-       let ((BasicBlock id fstmts):rblocks) = blocks'
+       let ((BasicBlock id fstmts):rblks) = blocks'
        fplog <- funPrologue
-       let fblocks = (BasicBlock id (fplog ++  allocs' ++ fstmts)):rblocks
+       let fblocks = (BasicBlock id (fplog ++  allocs' ++ fstmts)):rblks
        return (env, fblocks, tops)
 
 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
@@ -74,6 +76,16 @@ basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
        basicBlocksCodeGen env' blocks (lblocks, ltops)
 
 
+-- | Allocations need to be extracted so they can be moved to the entry
+-- of a function to make sure they dominate all possible paths in the CFG.
+dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
+dominateAllocs (BasicBlock id stmts)
+  = let (allocs, stmts') = partition isAlloc stmts
+        isAlloc (Assignment _ (Alloca _ _)) = True
+        isAlloc _other                      = False
+    in (BasicBlock id stmts', allocs)
+
+
 -- | Generate code for one block
 basicBlockCodeGen ::  LlvmEnv
                   -> CmmBasicBlock
@@ -83,19 +95,6 @@ basicBlockCodeGen env (BasicBlock id stmts)
        return (env', [BasicBlock id (fromOL instrs)], top)
 
 
--- | Allocations need to be extracted so they can be moved to the entry
--- of a function to make sure they dominate all possible paths in the CFG.
-dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
-dominateAllocs (BasicBlock id stmts)
-  = (BasicBlock id allstmts, allallocs)
-    where
-        (allstmts, allallocs) = foldl split ([],[]) stmts
-        split (stmts', allocs) s@(Assignment _ (Alloca _ _))
-            = (stmts', allocs ++ [s])
-        split (stmts', allocs) other
-            = (stmts' ++ [other], allocs)
-
-
 -- -----------------------------------------------------------------------------
 -- * CmmStmt code generation
 --
@@ -153,6 +152,10 @@ genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
 
 -- Write barrier needs to be handled specially as it is implemented as an LLVM
 -- intrinsic function.
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
+genCall env (CmmPrim MO_WriteBarrier) _ _ _ = return (env, nilOL, [])
+
+#else
 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
     let fname = fsLit "llvm.memory.barrier"
     let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
@@ -173,6 +176,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
     where
         lmTrue :: LlvmVar
         lmTrue  = LMLitVar $ LMIntLit (-1) i1
+#endif
 
 -- Handle all other foreign calls and prim ops.
 genCall env target res args ret = do