X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmMonad.hs;h=dbcb54075101331ab7a445d7db2965e53e8d5a1a;hb=a02e7f40afc1aab7fe466f949f505c1d7250713d;hp=c1f743dc56be1bab244d7c56c661ac1300c8f3ba;hpb=309f64a0fd319198308f6b76bd22f38001bb5df0;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index c1f743d..dbcb540 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -10,7 +10,7 @@ module StgCmmMonad (
 	FCode,	-- type
 
 	initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
-	returnFC, fixC, nopC, whenC, 
+	returnFC, fixC, fixC_, nopC, whenC, 
 	newUnique, newUniqSupply, 
 
 	emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
@@ -149,6 +149,8 @@ fixC fcode = FCode (
 			result
 	)
 
+fixC_ :: (a -> FCode a) -> FCode ()
+fixC_ fcode = fixC fcode >> return ()
 
 --------------------------------------------------------
 --	The code generator environment
@@ -213,6 +215,9 @@ data Sequel
                         -- space that's unused on this path?
                         -- We need to do this only if the expression may
                         -- allocate (e.g. it's a foreign call or allocating primOp)
+instance Show Sequel where
+  show (Return _) = "Sequel: Return"
+  show (AssignTo _ _) = "Sequel: Assign"
 
 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 initCgInfoDown dflags mod
@@ -504,7 +509,7 @@ forkProc body_code
   = do	{ info_down <- getInfoDown
 	; us    <- newUniqSupply
 	; state <- getState
-   	; let	info_down' = info_down { cgd_sequel = initSequel }
+   	; let	info_down' = info_down -- { cgd_sequel = initSequel }
                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
 		(result, fork_state_out) = doFCode body_code info_down' fork_state_in
   	; setState $ state `addCodeBlocksFrom` fork_state_out
@@ -598,13 +603,13 @@ emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
 emitProcWithConvention conv info lbl args blocks
   = do  { us <- newUniqSupply
         ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
-              blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
-        ; let proc_block = CmmProc info lbl args blks
+              blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
+        ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
 emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
-emitProc = emitProcWithConvention Native
+emitProc = emitProcWithConvention NativeNodeCall
 
 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 emitSimpleProc lbl code = 
@@ -630,5 +635,5 @@ getCmm code
 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
 cgStmtsToBlocks stmts
   = do  { us <- newUniqSupply
-	; return (initUs_ us (lgraphOfAGraph 0 stmts)) }	
+	; return (initUs_ us (lgraphOfAGraph stmts)) }