projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2005-05-21 15:39:00 by panne]
[ghc-hetmet.git] / ghc / compiler / cmm / PprC.hs
diff --git a/ghc/compiler/cmm/PprC.hs b/ghc/compiler/cmm/PprC.hs
index 51e429b..72a3cb1 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 CmdLineOpts     ( opt_EnsureSplittableC )
 
 -- The rest
 import Data.List        ( intersperse, groupBy )
@@ -59,16 +59,18 @@ 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_EnsureSplittableC = ptext SLIT("__STG_SPLIT_MARKER")
-  | otherwise             = empty
+writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs dflags handle cmms 
+  = printForUser handle alwaysQualify (pprCs dflags cmms)
+       -- ToDo: should be printForC
 
 -- --------------------------------------------------------------------------
 -- Now do some real work
@@ -85,7 +87,8 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 pprTop :: CmmTop -> SDoc
 pprTop (CmmProc info clbl _params blocks) =
     (if not (null info)
-        then pprWordArray (entryLblToInfoLbl clbl) info
+        then pprDataExterns info $$
+             pprWordArray (entryLblToInfoLbl clbl) info
         else empty) $$
     (case blocks of
         [] -> empty
@@ -177,10 +180,14 @@ pprStmt stmt = case stmt of
     CmmAssign dest src -> pprAssign dest src
 
     CmmStore  dest src
-       | rep == I64
+       | rep == I64 && wordRep /= I64
        -> 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
@@ -194,7 +201,7 @@ pprStmt stmt = case stmt of
        where
        ppr_fn = case fn of
                   CmmLit (CmmLabel lbl) -> pprCLabel lbl
-                  _other -> parens (cCast (pprCFunType results args) fn)
+                  _other -> parens (cCast (pprCFunType cconv results args) fn)
                        -- for a dynamic call, cast the expression to
                        -- a function of the right type (we hope).
 
@@ -217,9 +224,13 @@ pprStmt stmt = case stmt of
     CmmJump lbl _params      -> mkJMP_(pprExpr lbl) <> semi
     CmmSwitch arg ids        -> pprSwitch arg ids
 
-pprCFunType :: [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
-pprCFunType ress args = 
-  res_type ress <> parens (char '*') <> parens (commafy (map arg_type args))
+pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType cconv ress args
+  = hcat [
+       res_type ress,
+       parens (text (ccallConvAttribute cconv) <>  char '*'),
+       parens (commafy (map arg_type args))
+   ]
   where
        res_type [] = ptext SLIT("void")
        res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
@@ -265,11 +276,11 @@ pprSwitch e maybe_ids
     caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
        where 
        do_fallthrough ix =
-                 hsep [ ptext SLIT("case") , pprHexVal ix <> colon ,
+                 hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
                         ptext SLIT("/* fall through */") ]
 
        final_branch ix = 
-               hsep [ ptext SLIT("case") , pprHexVal ix <> colon ,
+               hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
                        ptext SLIT("goto") , (pprBlockId ident) <> semi ]
 
 -- ---------------------------------------------------------------------
@@ -290,9 +301,12 @@ pprExpr :: CmmExpr -> SDoc
 pprExpr e = case e of
     CmmLit lit -> pprLit lit
 
-    CmmLoad e I64
+    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
@@ -357,13 +371,24 @@ pprMachOpApp mop args
 
 pprLit :: CmmLit -> SDoc
 pprLit lit = case lit of
-    CmmInt i _rep      -> pprHexVal i
+    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 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_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+pprCLabelAddr lbl = char '&' <> pprCLabel lbl
 
 pprLit1 :: CmmLit -> SDoc
 pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
 pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
 pprLit1 other = pprLit other
 
@@ -503,7 +528,7 @@ pprCallishMachOp_for_C mop
         MO_F64_Cosh -> ptext SLIT("cosh")
         MO_F64_Tanh -> ptext SLIT("tanh")
         MO_F64_Asin -> ptext SLIT("asin")
-        MO_F64_Acos -> ptext SLIT("asin")
+        MO_F64_Acos -> ptext SLIT("acos")
         MO_F64_Atan -> ptext SLIT("atan")
         MO_F64_Log  -> ptext SLIT("log")
         MO_F64_Exp  -> ptext SLIT("exp")
@@ -624,6 +649,7 @@ 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
@@ -682,7 +708,7 @@ pprCall ppr_fn cconv results args vols
   where 
      ppr_results []     = empty
      ppr_results [(one,hint)] 
-        = pprExpr (CmmReg one) <> ptext SLIT(" = ")
+        = pprReg one <> ptext SLIT(" = ")
                 <> pprUnHint hint (cmmRegRep one)
      ppr_results _other = panic "pprCall: multiple results"
 
@@ -712,9 +738,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
@@ -780,6 +807,8 @@ te_BB (BasicBlock _ ss)             = mapM_ te_Stmt ss
 
 te_Lit :: CmmLit -> TE ()
 te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
 te_Lit _ = return ()
 
 te_Stmt :: CmmStmt -> TE ()
@@ -794,11 +823,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
@@ -957,12 +985,19 @@ commafy :: [SDoc] -> SDoc
 commafy xs = hsep $ punctuate comma xs
 
 -- Print in C hex format: 0x13fa
-pprHexVal :: Integer -> SDoc
-pprHexVal 0 = ptext SLIT("0x0")
-pprHexVal w 
-  | w < 0     = parens (char '-' <> ptext SLIT("0x") <> go (-w))
-  | otherwise = ptext SLIT("0x") <> go w
+pprHexVal :: Integer -> MachRep -> SDoc
+pprHexVal 0 _ = ptext SLIT("0x0")
+pprHexVal w rep
+  | w < 0     = parens (char '-' <> ptext SLIT("0x") <> go (-w) <> repsuffix 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")
+       -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
+      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("L")
+      repsuffix _ = empty
+      
       go 0 = empty
       go w' = go q <> dig
            where
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)