Cmm back end upgrades

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

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index d52b32e..2600da2 100644 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -7,7 +7,7 @@
 
 module MkZipCfgCmm
   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
 
 module MkZipCfgCmm
   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall

-         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment 
+         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry 

         , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
         , mkAddToContext
   , (<*>), catAGraphs, mkLabel, mkBranch
         , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
         , mkAddToContext
   , (<*>), catAGraphs, mkLabel, mkBranch

@@ -21,11 +21,14 @@ where
 
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
 
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo

-           , CmmCallTarget(..), CmmActuals, CmmFormals
+           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
+           , CmmKinded (..)

            )
            )

+import MachOp (MachHint(..))

 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- ^ to make this module more self-contained, these definitions are duplicated below
 import PprCmm()
 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- ^ to make this module more self-contained, these definitions are duplicated below
 import PprCmm()

+import StackSlot

 
 import ClosureInfo
 import FastString
 
 import ClosureInfo
 import FastString

@@ -66,7 +69,7 @@ mkReturn      :: CmmActuals -> CmmAGraph
 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph

-mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph 
+mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph

 
 -- Not to be forgotten, but exported by MkZipCfg:
 -- mkBranch      :: BlockId -> CmmAGraph
 
 -- Not to be forgotten, but exported by MkZipCfg:
 -- mkBranch      :: BlockId -> CmmAGraph

@@ -100,24 +103,67 @@ 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
+mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals

 
 

-cmmArgConv, cmmResConv :: Convention
-cmmArgConv = ConventionStandard CmmCallConv Arguments
+--cmmArgConv :: Convention
+cmmResConv :: Convention
+--cmmArgConv = ConventionStandard CmmCallConv Arguments

 cmmResConv = ConventionStandard CmmCallConv Arguments
 
 cmmResConv = ConventionStandard CmmCallConv Arguments
 

-mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
-mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
-
-mkFinalCall  f conv actuals =
-    mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
-    mkLast   (LastCall f Nothing)
+copyIn :: Convention -> StackArea -> CmmFormals -> [Middle]
+copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
+  where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
+                                       (CmmReg $ CmmStack $ StackSlot area n) : ms)
+
+copyOut :: Convention -> StackArea -> CmmActuals -> [Middle]
+copyOut _ area actuals = moveSP : reverse (snd $ foldl co (1, []) actuals)
+  where moveSP = MidAssign spReg $ CmmReg $ CmmStack $ outgoingSlot area
+        co (n, ms) v = (n+1, MidAssign (CmmStack $ StackSlot area n) 
+                                       (kindlessCmm v) : ms)
+mkEntry :: BlockId -> Convention -> CmmFormalsWithoutKinds -> [Middle]
+mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs
+  where fs = map (\f -> CmmKinded f NoHint) formals
+
+-- I'm not sure how to get the calling conventions right yet,
+-- and I suspect this should not be resolved until sometime after
+-- Simon's patch is applied.
+-- For now, I apply a bogus calling convention: all arguments go on the
+-- stack, using the same amount of stack space.
+lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) ->
+                CmmAGraph
+lastWithArgs conv actuals formals toLast =
+  withFreshLabel "call successor" $ \k ->
+    let area = mkStackArea k actuals formals
+    in (mkMiddles $ copyOut conv area actuals) <*>
+       -- adjust the sp
+       mkLast (toLast k) <*>
+       case formals of
+         Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
+         Nothing      -> emptyAGraph
+always :: a -> b -> a
+always x _ = x
+
+mkJump e actuals = lastWithArgs cmmResConv actuals Nothing $ always $ LastJump e
+mkReturn actuals = lastWithArgs cmmResConv actuals Nothing $ always LastReturn
+--mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
+--mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
+
+mkFinalCall f conv actuals =
+  lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
+      $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
+--    mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
+--    mkLast   (LastCall f Nothing)
+--

 
 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 
 
 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 

-mkCall f conv results actuals srt = 
-    withFreshLabel "call successor" $ \k ->
-      mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
-      mkLast (LastCall f (Just k)) <*>
-      mkLabel k <*>
-      mkMiddle (CopyIn (ConventionStandard conv Results) results srt)
+-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
+mkCall f conv results actuals _ =
+  lastWithArgs (ConventionStandard conv Arguments) actuals (Just results)
+        $ \k -> LastCall f (Just k)
+--mkCall f conv results actuals srt = 
+--    withFreshLabel "call successor" $ \k ->
+--      mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
+--      mkLast (LastCall f (Just k)) <*>
+--      mkLabel k <*>
+--      mkMiddle (CopyIn (ConventionStandard conv Results) results srt)