X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=e623c302be6e2f3700b122e64d5ee45742d49fab;hp=6792559aeea80be52a6a8937dd06eb92924caa5b;hb=0d80489c9b9f2421f65d8dd86c1e50c6bb429715;hpb=c0a5a5d2e41341046aaf37c1d2155372e7ed3ee8

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 6792559..e623c30 100644
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -6,10 +6,11 @@
 -- complain to Norman Ramsey.
 
 module MkZipCfgCmm
-  ( mkNop, mkAssign, mkStore, mkCall, mkUnsafeCall, mkFinalCall
-         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
-         , mkCmmWhileDo
-  , (<*>), mkLabel, mkBranch
+  ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
+         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry 
+	 , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
+	 , mkAddToContext
+  , (<*>), catAGraphs, mkLabel, mkBranch
   , emptyAGraph, withFreshLabel, withUnique, outOfLine
   , lgraphOfAGraph, graphOfAGraph, labelAGraph
   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle, Last, Convention(..)
@@ -18,10 +19,13 @@ where
 
 #include "HsVersions.h"
 
+import BlockId
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
-           , CmmCallTarget(..), CmmActuals, CmmFormals
+           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
+           , CmmKinded (..)
            )
+import MachOp (MachHint(..), wordRep)
 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- ^ to make this module more self-contained, these definitions are duplicated below
 import PprCmm()
@@ -38,47 +42,122 @@ type CmmBlock  = Block  Middle Last
 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
 
+---------- No-ops
 mkNop        :: CmmAGraph
+mkComment    :: FastString -> CmmAGraph
+
+---------- Assignment and store
 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
-mkCall       :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+
+---------- Calls
+mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+			-- Native C-- calling convention
 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
-mkFinalCall  :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns
-mkJump       :: CmmExpr -> CmmActuals -> CmmAGraph
-mkCbranch    :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
-mkSwitch     :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
-mkReturn     :: CmmActuals -> CmmAGraph
-mkComment    :: FastString -> CmmAGraph
+mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
+		 -- Never returns; like exit() or barf()
+
+---------- Context manipulation ('return via')
+mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
+
+---------- Control transfer
+mkJump       	:: Area    -> CmmExpr -> CmmActuals -> CmmAGraph
+mkCbranch    	:: CmmExpr -> BlockId -> BlockId    -> CmmAGraph
+mkSwitch     	:: CmmExpr -> [Maybe BlockId]       -> CmmAGraph
+mkReturn     	:: Area    -> CmmActuals            -> CmmAGraph
 
--- Not to be forgotten, but exported by MkZipCfg:
---mkBranch      :: BlockId -> CmmAGraph
---mkLabel       :: BlockId -> CmmAGraph
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
-mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph 
+mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
+mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
+
+-- Not to be forgotten, but exported by MkZipCfg:
+-- mkBranch   	  :: BlockId -> CmmAGraph
+-- mkLabel    	  :: BlockId -> CmmAGraph
+-- outOfLine  	  :: CmmAGraph -> CmmAGraph
+-- withUnique 	  :: (Unique -> CmmAGraph) -> CmmAGraph
+-- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
 
 --------------------------------------------------------------------------
 
+mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
-mkCmmWhileDo    e = mkWhileDo    (mkCbranch e)
+
+mkCmmIfThen e tbranch
+  = withFreshLabel "end of if"     $ \endif ->
+    withFreshLabel "start of then" $ \tid ->
+    mkCbranch e tid endif <*>
+    mkLabel tid <*> tbranch <*> mkBranch endif <*>
+    mkLabel endif
+
 
 
 -- ================ IMPLEMENTATION ================--
 
-mkNop                     = mkMiddle $ MidNop
+mkNop                     = emptyAGraph
 mkComment fs              = mkMiddle $ MidComment fs
 mkAssign l r              = mkMiddle $ MidAssign l r
 mkStore  l r              = mkMiddle $ MidStore  l r
 
-mkJump e args             = mkLast   $ LastJump e args
 mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
-mkReturn actuals          = mkLast   $ LastReturn actuals
 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 
 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
-mkFinalCall  tgt actuals         = mkLast   $ LastCall      tgt actuals Nothing
-
-mkCall tgt results actuals srt =
-  withFreshLabel "call successor" $ \k ->
-    mkLast (LastCall tgt actuals (Just k)) <*>
-    mkLabel k <*>
-    mkMiddle (CopyIn (Result CmmCallConv) results srt)
+mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
+
+cmmResConv :: Convention
+cmmResConv = ConventionStandard CmmCallConv Results
+
+copyIn :: Convention -> Area -> CmmFormals -> [Middle]
+copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
+  where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
+                                       (CmmLoad (CmmStackSlot area n) wordRep) : ms)
+
+copyOut :: Convention -> Area -> CmmActuals -> [Middle]
+copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals
+  where moveSP (ConventionStandard _ Arguments) args =
+           MidAssign spReg (outgoingSlot area) : reverse args
+        moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args
+        co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms)
+mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle]
+mkEntry area conv formals = copyIn conv area 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' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals ->
+                 (BlockId -> Last) -> CmmAGraph
+lastWithArgs' k area conv actuals formals toLast =
+  (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
+lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph
+lastWithArgs c a f l =
+  withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l
+
+always :: a -> b -> a
+always x _ = x
+
+-- The area created for the jump and return arguments is the same area as the
+-- procedure entry.
+mkJump   area e actuals =
+  lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always $ LastJump e
+mkReturn area   actuals =
+  lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always LastReturn
+
+mkFinalCall f conv actuals =
+  lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
+      $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
+
+mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals 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)