floating-point fix for x86_64

[ghc-hetmet.git] / ghc / compiler / cmm / PprC.hs

diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index 8bcfd0c..6ce2df5 100644 (file)
--- a/ghc/compiler/cmm/PprC.hs
+++ b/ghc/compiler/cmm/PprC.hs
@@ -45,6 +45,7 @@ import Data.Bits        ( shiftR )
 import Char             ( ord, chr )
 import IO               ( Handle )
 import DATA_BITS
+import Data.Word       ( Word8 )
 
 #ifdef DEBUG
 import PprCmm          () -- instances only
@@ -532,19 +533,19 @@ pprCallishMachOp_for_C mop
         MO_F64_Log  -> ptext SLIT("log")
         MO_F64_Exp  -> ptext SLIT("exp")
         MO_F64_Sqrt -> ptext SLIT("sqrt")
-        MO_F32_Pwr  -> ptext SLIT("pow")
-        MO_F32_Sin  -> ptext SLIT("sin")
-        MO_F32_Cos  -> ptext SLIT("cos")
-        MO_F32_Tan  -> ptext SLIT("tan")
-        MO_F32_Sinh -> ptext SLIT("sinh")
-        MO_F32_Cosh -> ptext SLIT("cosh")
-        MO_F32_Tanh -> ptext SLIT("tanh")
-        MO_F32_Asin -> ptext SLIT("asin")
-        MO_F32_Acos -> ptext SLIT("acos")
-        MO_F32_Atan -> ptext SLIT("atan")
-        MO_F32_Log  -> ptext SLIT("log")
-        MO_F32_Exp  -> ptext SLIT("exp")
-        MO_F32_Sqrt -> ptext SLIT("sqrt")
+        MO_F32_Pwr  -> ptext SLIT("powf")
+        MO_F32_Sin  -> ptext SLIT("sinf")
+        MO_F32_Cos  -> ptext SLIT("cosf")
+        MO_F32_Tan  -> ptext SLIT("tanf")
+        MO_F32_Sinh -> ptext SLIT("sinhf")
+        MO_F32_Cosh -> ptext SLIT("coshf")
+        MO_F32_Tanh -> ptext SLIT("tanhf")
+        MO_F32_Asin -> ptext SLIT("asinf")
+        MO_F32_Acos -> ptext SLIT("acosf")
+        MO_F32_Atan -> ptext SLIT("atanf")
+        MO_F32_Log  -> ptext SLIT("logf")
+        MO_F32_Exp  -> ptext SLIT("expf")
+        MO_F32_Sqrt -> ptext SLIT("sqrtf")
 
 -- ---------------------------------------------------------------------
 -- Useful #defines
@@ -654,6 +655,7 @@ isStrangeTypeGlobal r                       = isPtrGlobalReg r
 strangeRegType :: CmmReg -> Maybe SDoc
 strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
 strangeRegType (CmmGlobal CurrentNursery) = Just (ptext SLIT("struct bdescr_ *"))
+strangeRegType (CmmGlobal BaseReg) = Just (ptext SLIT("struct StgRegTable_ *"))
 strangeRegType _ = Nothing
 
 -- pprReg just prints the register name.
@@ -695,21 +697,28 @@ pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
 
 pprCall ppr_fn cconv results args vols
   | not (is_cish cconv)
-  = panic "pprForeignCall: unknown calling convention"
+  = panic "pprCall: unknown calling convention"
 
   | otherwise
   = save vols $$
     ptext SLIT("CALLER_SAVE_SYSTEM") $$
-    hcat [ ppr_results results, ppr_fn, 
-          parens (commafy (map pprArg args)), semi ] $$
+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$
     ptext SLIT("CALLER_RESTORE_SYSTEM") $$
     restore vols
   where 
-     ppr_results []     = empty
-     ppr_results [(one,hint)] 
+     ppr_assign []           rhs = rhs
+     ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
+        | Just ty <- strangeRegType reg
+        = ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs)
+        -- BaseReg is special, sometimes it isn't an lvalue and we
+        -- can't assign to it.
+     ppr_assign [(one,hint)] rhs
+        | Just ty <- strangeRegType one
+        = pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs
+        | otherwise
         = pprReg one <> ptext SLIT(" = ")
-                <> pprUnHint hint (cmmRegRep one)
-     ppr_results _other = panic "pprCall: multiple results"
+                <> pprUnHint hint (cmmRegRep one) <> rhs
+     ppr_assign _other _rhs = panic "pprCall: multiple results"
 
      pprArg (expr, PtrHint)
        = cCast (ptext SLIT("void *")) expr
@@ -877,25 +886,21 @@ machRepSignedCType r | r == wordRep = ptext SLIT("I_")
 -- ---------------------------------------------------------------------
 -- print strings as valid C strings
 
--- Assumes it contains only characters '\0'..'\xFF'!
-pprFSInCStyle :: FastString -> SDoc
-pprFSInCStyle fs = pprStringInCStyle (unpackFS fs)
-
-pprStringInCStyle :: String -> SDoc
+pprStringInCStyle :: [Word8] -> SDoc
 pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
 
-charToC :: Char -> String
-charToC '\"' = "\\\""
-charToC '\'' = "\\\'"
-charToC '\\' = "\\\\"
-charToC c | c >= ' ' && c <= '~' = [c]
-          | c > '\xFF' = panic ("charToC "++show c)
-          | otherwise = ['\\',
+charToC :: Word8 -> String
+charToC w = 
+  case chr (fromIntegral w) of
+       '\"' -> "\\\""
+       '\'' -> "\\\'"
+       '\\' -> "\\\\"
+       c | c >= ' ' && c <= '~' -> [c]
+          | otherwise -> ['\\',
                          chr (ord '0' + ord c `div` 64),
                          chr (ord '0' + ord c `div` 8 `mod` 8),
                          chr (ord '0' + ord c         `mod` 8)]
 
-
 -- ---------------------------------------------------------------------------
 -- Initialising static objects with floating-point numbers.  We can't
 -- just emit the floating point number, because C will cast it to an int