diff options
| -rw-r--r-- | compiler/cmm/CmmCvt.hs | 5 | ||||
| -rw-r--r-- | compiler/cmm/CmmLiveZ.hs | 1 | ||||
| -rw-r--r-- | compiler/cmm/CmmSpillReload.hs | 1 | ||||
| -rw-r--r-- | compiler/cmm/MkZipCfgCmm.hs | 6 | ||||
| -rw-r--r-- | compiler/cmm/ZipCfgCmmRep.hs | 37 |
5 files changed, 37 insertions, 13 deletions
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 42859abd7f..107046c7f0 100644 --- 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 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') diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index 09ff52166b..ab71d673b9 100644 --- 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 (MidAddToContext ra args) = gen ra . gen args middle (CopyIn _ formals _) = kill formals middle (CopyOut _ actuals) = gen actuals diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index dedef086aa..6f59e8f093 100644 --- 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 (MidAddToContext {}) = id middle (CopyIn _ formals _) = akill formals middle (CopyOut {}) = id diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 34e7dff69c..890b37c3bc 100644 --- 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 - , mkCmmWhileDo + , mkCmmWhileDo, mkAddToContext , (<*>), 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() +---------- Context manipulation ('return via') +mkAddToContext :: CmmExpr -> [CmmExpr] -> 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 +mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals cmmArgConv, cmmResConv :: Convention cmmArgConv = ConventionStandard CmmCallConv Arguments diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 0b93d1a0ea..b710a941b0 100644 --- 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 + | 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 @@ -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 - 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 (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 @@ -230,16 +239,18 @@ pprMiddle stmt = (case stmt of 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 ] - 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) + + MidAddToContext ra args -> + hcat [ ptext SLIT("return via ") + , ppr_target ra, parens (commafy $ map ppr args), semi ] + ) <> if debugPpr then empty else text " //" <+> @@ -249,7 +260,13 @@ pprMiddle stmt = (case stmt of 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 |