X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FX86%2FCodeGen.hs;h=cc942fbf3bb52730740d770009367d8418b1646f;hp=a6cc36fcb76743cec53f8f924a242f108943d37f;hb=93d6c9d532b678a91bafd4bf5f5f10c4f4b6d9b9;hpb=5fb59c02d3829cdd88cb2180237aba4ea4a2f66a

diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index a6cc36f..cc942fb 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -69,7 +69,7 @@ import DynFlags
 import Debug.Trace	( trace )
 
 import Control.Monad	( mapAndUnzipM )
-import Data.Maybe	( fromJust )
+import Data.Maybe	( fromJust, catMaybes )
 import Data.Bits
 import Data.Word
 import Data.Int
@@ -1519,14 +1519,18 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
 	-- write barrier compiles to no code on x86/x86-64; 
 	-- we keep it this long in order to prevent earlier optimisations.
 
+-- void return type prim op
+genCCall (CmmPrim op) [] args =
+    outOfLineCmmOp op Nothing args
+
 -- we only cope with a single result for foreign calls
-genCCall (CmmPrim op) [CmmHinted r _] args = do
+genCCall (CmmPrim op) [r_hinted@(CmmHinted r _)] args = do
   l1 <- getNewLabelNat
   l2 <- getNewLabelNat
   sse2 <- sse2Enabled
   if sse2
     then
-      outOfLineFloatOp op r args
+      outOfLineCmmOp op (Just r_hinted) args
     else case op of
 	MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
 	MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
@@ -1540,7 +1544,7 @@ genCCall (CmmPrim op) [CmmHinted r _] args = do
 	MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
 	MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
 	
-	other_op    -> outOfLineFloatOp op r args
+	other_op    -> outOfLineCmmOp op (Just r_hinted) args
 
  where
   actuallyInlineFloatOp instr size [CmmHinted x _]
@@ -1569,7 +1573,6 @@ genCCall target dest_regs args = do
     -- deal with static vs dynamic call targets
     (callinsns,cconv) <-
       case target of
-	-- CmmPrim -> ...
         CmmCallee (CmmLit (CmmLabel lbl)) conv
            -> -- ToDo: stdcall arg sizes
 	      return (unitOL (CALL (Left fn_imm) []), conv)
@@ -1578,6 +1581,9 @@ genCCall target dest_regs args = do
            -> do { (dyn_r, dyn_c) <- getSomeReg expr
                  ; ASSERT( isWord32 (cmmExprType expr) )
                    return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
+        CmmPrim _
+            -> panic $ "genCCall: Can't handle CmmPrim call type here, error "
+                        ++ "probably because too many return values."
 
     let	push_code
 #if darwin_TARGET_OS
@@ -1649,7 +1655,6 @@ genCCall target dest_regs args = do
     roundTo a x | x `mod` a == 0 = x
                 | otherwise = x + a - (x `mod` a)
 
-
     push_arg :: Bool -> HintedCmmActual {-current argument-}
                     -> NatM InstrBlock  -- code
 
@@ -1703,9 +1708,13 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
 	-- write barrier compiles to no code on x86/x86-64; 
 	-- we keep it this long in order to prevent earlier optimisations.
 
+-- void return type prim op
+genCCall (CmmPrim op) [] args =
+  outOfLineCmmOp op Nothing args
 
-genCCall (CmmPrim op) [CmmHinted r _] args = 
-  outOfLineFloatOp op r args
+-- we only cope with a single result for foreign calls
+genCCall (CmmPrim op) [res] args =
+  outOfLineCmmOp op (Just res) args
 
 genCCall target dest_regs args = do
 
@@ -1749,7 +1758,6 @@ genCCall target dest_regs args = do
     -- deal with static vs dynamic call targets
     (callinsns,cconv) <-
       case target of
-	-- CmmPrim -> ...
         CmmCallee (CmmLit (CmmLabel lbl)) conv
            -> -- ToDo: stdcall arg sizes
 	      return (unitOL (CALL (Left fn_imm) arg_regs), conv)
@@ -1757,6 +1765,9 @@ genCCall target dest_regs args = do
         CmmCallee expr conv
            -> do (dyn_r, dyn_c) <- getSomeReg expr
 		 return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
+        CmmPrim _
+            -> panic $ "genCCall: Can't handle CmmPrim call type here, error "
+                        ++ "probably because too many return values."
 
     let
 	-- The x86_64 ABI requires us to set %al to the number of SSE2
@@ -1867,22 +1878,26 @@ genCCall	= panic "X86.genCCAll: not defined"
 #endif /* x86_64_TARGET_ARCH */
 
 
-
-
-outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals -> NatM InstrBlock
-outOfLineFloatOp mop res args
+outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> HintedCmmActuals -> NatM InstrBlock
+outOfLineCmmOp mop res args
   = do
       dflags <- getDynFlagsNat
       targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
       let target = CmmCallee targetExpr CCallConv
      
-      stmtToInstrs (CmmCall target [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn)
+      stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmUnsafe CmmMayReturn)
   where
 	-- Assume we can call these functions directly, and that they're not in a dynamic library.
 	-- TODO: Why is this ok? Under linux this code will be in libm.so
 	--	 Is is because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31 
 	lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction
 
+        args' = case mop of
+                    MO_Memcpy    -> init args
+                    MO_Memset    -> init args
+                    MO_Memmove   -> init args
+                    _            -> args
+
 	fn = case mop of
 	      MO_F32_Sqrt  -> fsLit "sqrtf"
 	      MO_F32_Sin   -> fsLit "sinf"
@@ -1916,8 +1931,9 @@ outOfLineFloatOp mop res args
 	      MO_F64_Tanh  -> fsLit "tanh"
 	      MO_F64_Pwr   -> fsLit "pow"
 
-
-
+	      MO_Memcpy    -> fsLit "memcpy"
+	      MO_Memset    -> fsLit "memset"
+	      MO_Memmove   -> fsLit "memmove"
 
 
 -- -----------------------------------------------------------------------------