projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix Trace #1494
[ghc-hetmet.git]
/
compiler
/
cmm
/
PprC.hs
diff --git
a/compiler/cmm/PprC.hs
b/compiler/cmm/PprC.hs
index
d9bdca5
..
1a909f2
100644
(file)
--- a/
compiler/cmm/PprC.hs
+++ b/
compiler/cmm/PprC.hs
@@
-28,6
+28,7
@@
import Cmm
import CLabel
import MachOp
import ForeignCall
import CLabel
import MachOp
import ForeignCall
+import ClosureInfo
-- Utils
import DynFlags
-- Utils
import DynFlags
@@
-65,7
+66,7
@@
import StaticFlags ( opt_Unregisterised )
-- --------------------------------------------------------------------------
-- Top level
-- --------------------------------------------------------------------------
-- Top level
-pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs :: DynFlags -> [RawCmm] -> SDoc
pprCs dflags cmms
= pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
pprCs dflags cmms
= pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
@@
-73,7
+74,7
@@
pprCs dflags cmms
| dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
| otherwise = empty
| dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
| otherwise = empty
-writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
writeCs dflags handle cmms
= printForC handle (pprCs dflags cmms)
writeCs dflags handle cmms
= printForC handle (pprCs dflags cmms)
@@
-83,13
+84,13
@@
writeCs dflags handle cmms
-- for fun, we could call cmmToCmm over the tops...
--
-- for fun, we could call cmmToCmm over the tops...
--
-pprC :: Cmm -> SDoc
+pprC :: RawCmm -> SDoc
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
--
-- top level procs
--
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
--
-- top level procs
--
-pprTop :: CmmTop -> SDoc
+pprTop :: RawCmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
then pprDataExterns info $$
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
then pprDataExterns info $$
@@
-198,15
+199,15
@@
pprStmt stmt = case stmt of
where
rep = cmmExprRep src
where
rep = cmmExprRep src
- CmmCall (CmmForeignCall fn cconv) results args ->
+ CmmCall (CmmForeignCall fn cconv) results args safety ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
-- Controversial: leave this out for now.
-- pprUndef fn $$
- pprCall ppr_fn cconv results args
+ pprCall ppr_fn cconv results args safety
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
- _other -> parens (cCast (pprCFunType cconv results args) fn)
+ _ -> parens (cCast (pprCFunType cconv results args) fn)
-- for a dynamic call, cast the expression to
-- a function of the right type (we hope).
-- for a dynamic call, cast the expression to
-- a function of the right type (we hope).
@@
-219,8
+220,8
@@
pprStmt stmt = case stmt of
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
- CmmCall (CmmPrim op) results args ->
- pprCall ppr_fn CCallConv results args
+ CmmCall (CmmPrim op) results args safety ->
+ pprCall ppr_fn CCallConv results args safety
where
ppr_fn = pprCallishMachOp_for_C op
where
ppr_fn = pprCallishMachOp_for_C op
@@
-229,7
+230,7
@@
pprStmt stmt = case stmt of
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
-pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType :: CCallConv -> CmmHintFormals -> CmmActuals -> SDoc
pprCFunType cconv ress args
= hcat [
res_type ress,
pprCFunType cconv ress args
= hcat [
res_type ress,
@@
-238,7
+239,7
@@
pprCFunType cconv ress args
]
where
res_type [] = ptext SLIT("void")
]
where
res_type [] = ptext SLIT("void")
- res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
+ res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
@@
-713,15
+714,15
@@
pprGlobalReg gr = case gr of
GCFun -> ptext SLIT("stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
GCFun -> ptext SLIT("stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
+pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
-> SDoc
-> SDoc
-pprCall ppr_fn cconv results args
+pprCall ppr_fn cconv results args _
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
| not (is_cish cconv)
= panic "pprCall: unknown calling convention"
@@
-741,17
+742,9
@@
pprCall ppr_fn cconv results args
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
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
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) <> rhs
+ = pprLocalReg one <> ptext SLIT(" = ")
+ <> pprUnHint hint (localRegRep one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
@@
-792,7
+785,7
@@
pprDataExterns statics
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
-pprTempDecl l@(LocalReg _uniq rep)
+pprTempDecl l@(LocalReg _ rep _)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
pprExternDecl :: Bool -> CLabel -> SDoc
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
pprExternDecl :: Bool -> CLabel -> SDoc
@@
-847,7
+840,7
@@
te_Lit _ = return ()
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
te_Stmt :: CmmStmt -> TE ()
te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
-te_Stmt (CmmCall _ rs es) = mapM_ (te_Reg.fst) rs >>
+te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.fst) rs >>
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e