projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
4b0d762
)
added node to push a closure onto the current call context
author
Norman Ramsey
<nr@eecs.harvard.edu>
Mon, 17 Sep 2007 17:29:39 +0000
(17:29 +0000)
committer
Norman Ramsey
<nr@eecs.harvard.edu>
Mon, 17 Sep 2007 17:29:39 +0000
(17:29 +0000)
compiler/cmm/CmmCvt.hs
patch
|
blob
|
history
compiler/cmm/CmmLiveZ.hs
patch
|
blob
|
history
compiler/cmm/CmmSpillReload.hs
patch
|
blob
|
history
compiler/cmm/MkZipCfgCmm.hs
patch
|
blob
|
history
compiler/cmm/ZipCfgCmmRep.hs
patch
|
blob
|
history
diff --git
a/compiler/cmm/CmmCvt.hs
b/compiler/cmm/CmmCvt.hs
index
42859ab
..
107046c
100644
(file)
--- a/
compiler/cmm/CmmCvt.hs
+++ b/
compiler/cmm/CmmCvt.hs
@@
-85,8
+85,9
@@
ofZgraph g = ListGraph $ swallow blocks
mid (MidAssign l r) = CmmAssign l r
mid (MidStore l r) = CmmStore l r
mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
mid (MidAssign l r) = CmmAssign l r
mid (MidStore l r) = CmmStore l r
mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
- mid m@(CopyOut {}) = pcomment (ppr m)
- mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
+ mid m@(MidAddToContext {}) = pcomment (ppr m)
+ mid m@(CopyOut {}) = pcomment (ppr m)
+ mid m@(CopyIn {}) = pcomment (ppr m <+> text "(proc point)")
pcomment p = scomment $ showSDoc p
block' id prev'
| id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
pcomment p = scomment $ showSDoc p
block' id prev'
| id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
diff --git
a/compiler/cmm/CmmLiveZ.hs
b/compiler/cmm/CmmLiveZ.hs
index
09ff521
..
ab71d67
100644
(file)
--- a/
compiler/cmm/CmmLiveZ.hs
+++ b/
compiler/cmm/CmmLiveZ.hs
@@
-60,6
+60,7
@@
middleLiveness m = middle m
middle (MidAssign lhs expr) = gen expr . kill lhs
middle (MidStore addr rval) = gen addr . gen rval
middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
middle (MidAssign lhs expr) = gen expr . kill lhs
middle (MidStore addr rval) = gen addr . gen rval
middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
+ middle (MidAddToContext ra args) = gen ra . gen args
middle (CopyIn _ formals _) = kill formals
middle (CopyOut _ actuals) = gen actuals
middle (CopyIn _ formals _) = kill formals
middle (CopyOut _ actuals) = gen actuals
diff --git
a/compiler/cmm/CmmSpillReload.hs
b/compiler/cmm/CmmSpillReload.hs
index
dedef08
..
6f59e8f
100644
(file)
--- a/
compiler/cmm/CmmSpillReload.hs
+++ b/
compiler/cmm/CmmSpillReload.hs
@@
-262,6
+262,7
@@
middleAvail (NotSpillOrReload m) = middle m
middle (MidAssign lhs _expr) = akill lhs
middle (MidStore {}) = id
middle (MidUnsafeCall _tgt ress _args) = akill ress
middle (MidAssign lhs _expr) = akill lhs
middle (MidStore {}) = id
middle (MidUnsafeCall _tgt ress _args) = akill ress
+ middle (MidAddToContext {}) = id
middle (CopyIn _ formals _) = akill formals
middle (CopyOut {}) = id
middle (CopyIn _ formals _) = akill formals
middle (CopyOut {}) = id
diff --git
a/compiler/cmm/MkZipCfgCmm.hs
b/compiler/cmm/MkZipCfgCmm.hs
index
34e7dff
..
890b37c
100644
(file)
--- a/
compiler/cmm/MkZipCfgCmm.hs
+++ b/
compiler/cmm/MkZipCfgCmm.hs
@@
-8,7
+8,7
@@
module MkZipCfgCmm
( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
, mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
module MkZipCfgCmm
( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
, mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
- , mkCmmWhileDo
+ , mkCmmWhileDo, mkAddToContext
, (<*>), sequence, mkLabel, mkBranch
, emptyAGraph, withFreshLabel, withUnique, outOfLine
, lgraphOfAGraph, graphOfAGraph, labelAGraph
, (<*>), sequence, mkLabel, mkBranch
, emptyAGraph, withFreshLabel, withUnique, outOfLine
, lgraphOfAGraph, graphOfAGraph, labelAGraph
@@
-55,6
+55,9
@@
mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
-- Never returns; like exit() or barf()
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
-- Never returns; like exit() or barf()
+---------- Context manipulation ('return via')
+mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
+
---------- Control transfer
mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
---------- Control transfer
mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
@@
-87,6
+90,7
@@
mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot
mkSwitch e tbl = mkLast $ LastSwitch e tbl
mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
mkSwitch e tbl = mkLast $ LastSwitch e tbl
mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
+mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
cmmArgConv, cmmResConv :: Convention
cmmArgConv = ConventionStandard CmmCallConv Arguments
cmmArgConv, cmmResConv :: Convention
cmmArgConv = ConventionStandard CmmCallConv Arguments
diff --git
a/compiler/cmm/ZipCfgCmmRep.hs
b/compiler/cmm/ZipCfgCmmRep.hs
index
0b93d1a
..
b710a94
100644
(file)
--- a/
compiler/cmm/ZipCfgCmmRep.hs
+++ b/
compiler/cmm/ZipCfgCmmRep.hs
@@
-55,6
+55,14
@@
data Middle
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
CmmFormals -- zero or more results
CmmActuals -- zero or more arguments
+ | MidAddToContext -- push a frame on the stack;
+ -- I will return to this frame
+ CmmExpr -- The frame's return address; it must be
+ -- preceded by an info table that describes the
+ -- live variables.
+ [CmmExpr] -- The frame's live variables, to go on the
+ -- stack with the first one at the young end
+
| CopyIn -- Move incoming parameters or results from conventional
-- locations to registers. Note [CopyIn invariant]
Convention
| CopyIn -- Move incoming parameters or results from conventional
-- locations to registers. Note [CopyIn invariant]
Convention
@@
-157,12
+165,13
@@
fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edge
instance UserOfLocalRegs Middle where
foldRegsUsed f z m = middle m
where middle (MidComment {}) = z
instance UserOfLocalRegs Middle where
foldRegsUsed f z m = middle m
where middle (MidComment {}) = z
- middle (MidAssign _lhs expr) = foldRegsUsed f z expr
- middle (MidStore addr rval) = foldRegsUsed f (foldRegsUsed f z addr) rval
- middle (MidUnsafeCall tgt _ress args) = foldRegsUsed f (foldRegsUsed f z tgt) args
+ middle (MidAssign _lhs expr) = fold f z expr
+ middle (MidStore addr rval) = fold f (fold f z addr) rval
+ middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
+ middle (MidAddToContext ra args) = fold f (fold f z ra) args
middle (CopyIn _ _formals _) = z
middle (CopyIn _ _formals _) = z
- middle (CopyOut _ actuals) = foldRegsUsed f z actuals
--- fold = foldRegsUsed
+ middle (CopyOut _ actuals) = fold f z actuals
+ fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
instance UserOfLocalRegs Last where
foldRegsUsed f z m = last m
instance UserOfLocalRegs Last where
foldRegsUsed f z m = last m
@@
-230,16
+239,18
@@
pprMiddle stmt = (case stmt of
ptext SLIT(" = "),
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
ptext SLIT(" = "),
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
- target fn, parens ( commafy $ map ppr args ),
+ ppr_target fn, parens ( commafy $ map ppr args ),
semi ]
semi ]
- where
- target t@(CmmLit _) = ppr t
- target fn' = parens (ppr fn')
MidUnsafeCall (CmmPrim op) results args ->
pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
MidUnsafeCall (CmmPrim op) results args ->
pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
+
+ MidAddToContext ra args ->
+ hcat [ ptext SLIT("return via ")
+ , ppr_target ra, parens (commafy $ map ppr args), semi ]
+
) <>
if debugPpr then empty
else text " //" <+>
) <>
if debugPpr then empty
else text " //" <+>
@@
-249,7
+260,13
@@
pprMiddle stmt = (case stmt of
MidComment {} -> text "MidComment"
MidAssign {} -> text "MidAssign"
MidStore {} -> text "MidStore"
MidComment {} -> text "MidComment"
MidAssign {} -> text "MidAssign"
MidStore {} -> text "MidStore"
- MidUnsafeCall {} -> text "MidUnsafeCall"
+ MidUnsafeCall {} -> text "MidUnsafeCall"
+ MidAddToContext {} -> text "MidAddToContext"
+
+
+ppr_target :: CmmExpr -> SDoc
+ppr_target t@(CmmLit _) = ppr t
+ppr_target fn' = parens (ppr fn')
pprHinted :: Outputable a => (a, MachHint) -> SDoc
pprHinted :: Outputable a => (a, MachHint) -> SDoc