[project @ 2005-11-02 11:56:56 by simonmar]

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

diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index 04c8194..7427f50 100644 (file)
--- a/ghc/compiler/cmm/PprC.hs
+++ b/ghc/compiler/cmm/PprC.hs
@@ -30,6 +30,7 @@ import MachOp
 import ForeignCall
 
 -- Utils
+import DynFlags                ( DynFlags, DynFlag(..), dopt )
 import Unique           ( getUnique )
 import UniqSet
 import FiniteMap
@@ -37,7 +38,6 @@ import UniqFM         ( eltsUFM )
 import FastString
 import Outputable
 import Constants
-import StaticFlags     ( opt_SplitObjs )
 
 -- The rest
 import Data.List        ( intersperse, groupBy )
@@ -59,16 +59,17 @@ import MONAD_ST
 -- --------------------------------------------------------------------------
 -- Top level
 
-pprCs :: [Cmm] -> SDoc
-pprCs cmms = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
-
-writeCs :: Handle -> [Cmm] -> IO ()
-writeCs handle cmms = printForUser handle alwaysQualify (pprCs cmms)
-                       -- ToDo: should be printForC
+pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs dflags cmms
+ = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
+ where
+   split_marker
+     | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
+     | otherwise                = empty
 
-split_marker
-  | opt_SplitObjs = ptext SLIT("__STG_SPLIT_MARKER")
-  | otherwise     = empty
+writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs dflags handle cmms 
+  = printForC handle (pprCs dflags cmms)
 
 -- --------------------------------------------------------------------------
 -- Now do some real work
@@ -182,6 +183,10 @@ pprStmt stmt = case stmt of
        -> ptext SLIT("ASSIGN_Word64") <> 
                parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
 
+       | rep == F64 && wordRep /= I64
+       -> ptext SLIT("ASSIGN_DBL") <> 
+               parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
        | otherwise
        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
        where
@@ -298,6 +303,9 @@ pprExpr e = case e of
     CmmLoad e I64 | wordRep /= I64
        -> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e)
 
+    CmmLoad e F64 | wordRep /= I64
+       -> ptext SLIT("PK_DBL") <> parens (mkP_ <> pprExpr1 e)
+
     CmmLoad (CmmReg r) rep 
        | isPtrReg r && rep == wordRep
        -> char '*' <> pprAsPtrReg r
@@ -364,16 +372,18 @@ pprLit :: CmmLit -> SDoc
 pprLit lit = case lit of
     CmmInt i rep      -> pprHexVal i rep
     CmmFloat f rep     -> parens (machRepCType rep) <> (rational f)
-    CmmLabel clbl      -> mkW_ <> pprCLabel clbl
-    CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i
+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
     CmmLabelDiffOff clbl1 clbl2 i
         -- WARNING:
-        -- * the lit must occur in the info table clbl2
-        -- * clbl1 must be an SRT, a slow entry point or a large bitmap
+        --  * the lit must occur in the info table clbl2
+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
         -- The Mangler is expected to convert any reference to an SRT,
         -- a slow entry point or a large bitmap
         -- from an info table to an offset.
-        -> mkW_ <> pprCLabel clbl1 <> char '+' <> int i
+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+pprCLabelAddr lbl = char '&' <> pprCLabel lbl
 
 pprLit1 :: CmmLit -> SDoc
 pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
@@ -638,11 +648,13 @@ isStrangeTypeReg (CmmGlobal g)    = isStrangeTypeGlobal g
 isStrangeTypeGlobal :: GlobalReg -> Bool
 isStrangeTypeGlobal CurrentTSO         = True
 isStrangeTypeGlobal CurrentNursery     = True
+isStrangeTypeGlobal BaseReg            = True
 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.
@@ -696,7 +708,10 @@ pprCall ppr_fn cconv results args vols
   where 
      ppr_results []     = empty
      ppr_results [(one,hint)] 
-        = pprExpr (CmmReg one) <> ptext SLIT(" = ")
+        | Just ty <- strangeRegType one
+        = pprReg one <> ptext SLIT(" = ") <> parens ty
+        | otherwise
+        = pprReg one <> ptext SLIT(" = ")
                 <> pprUnHint hint (cmmRegRep one)
      ppr_results _other = panic "pprCall: multiple results"
 
@@ -726,9 +741,10 @@ pprGlobalRegName gr = case gr of
     VanillaReg n   -> char 'R' <> int n  -- without the .w suffix
     _              -> pprGlobalReg gr
 
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
 is_cish CCallConv   = True
 is_cish StdCallConv = True
-is_cish _          = False
 
 -- ---------------------------------------------------------------------
 -- Find and print local and external declarations for a list of
@@ -810,11 +826,10 @@ te_Stmt _                 = return ()
 
 te_Expr :: CmmExpr -> TE ()
 te_Expr (CmmLit lit)           = te_Lit lit
-te_Expr (CmmReg r)             = te_Reg r
 te_Expr (CmmLoad e _)          = te_Expr e
+te_Expr (CmmReg r)             = te_Reg r
 te_Expr (CmmMachOp _ es)       = mapM_ te_Expr es
 te_Expr (CmmRegOff r _)        = te_Reg r
-te_Expr _                      = return ()
 
 te_Reg :: CmmReg -> TE ()
 te_Reg (CmmLocal l) = te_temp l
@@ -980,11 +995,16 @@ pprHexVal w rep
   | otherwise = ptext SLIT("0x") <> go w <> repsuffix rep
   where
        -- type suffix for literals:
-       -- on 32-bit platforms, add "LL" to 64-bit literals
-      repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("LL")
+       -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
+       -- signed values for doing signed operations, but at all other
+       -- times values are unsigned.  This also helps eliminate occasional
+       -- warnings about integer overflow from gcc.
+
+       -- on 32-bit platforms, add "ULL" to 64-bit literals
+      repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("ULL")
        -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
-      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("L")
-      repsuffix _ = empty
+      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("UL")
+      repsuffix _ = char 'U'
       
       go 0 = empty
       go w' = go q <> dig