A few bug fixes; some improvements spurred by paper writing

Among others:
- Fixed Stg->C-- translation of let-no-escapes -- it's important to use the
  right continuation...
- Fixed infinite recursion in X86 backend (shortcutJump mishandled infinite loops)
- Fixed yet another wrong calling convention -- primops take args only in vanilla regs,
  but they may return results on the stack!
- Removed StackInfo from LGraph and Block -- now in LastCall and CmmZ
- Updated avail-variable and liveness code

6 files changed, 47 insertions, 35 deletions

diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 0fc6c4c5a8..ae4fa1b623 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -239,8 +239,7 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
     check_already_done retId updfr_sz
      = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
-		       (mkLabel retId emptyStackInfo
-                    <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
+		       (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
 	<*>  	-- Set mod_reg to 1 to record that we've been here
 	    mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
 
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 369564cba8..df6e8a1a47 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -42,6 +42,7 @@ import Maybes
 import Util
 import FastString
 import Outputable
+import UniqSupply
 
 ------------------------------------------------------------------------
 --		cgExpr: the main function
@@ -57,8 +58,13 @@ cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
 cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
                                emitReturn [CmmLit cmm_lit]
 
-cgExpr (StgLet binds expr)  	       = do { cgBind binds; cgExpr expr }
-cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
+cgExpr (StgLet binds expr)             = do { cgBind binds;     cgExpr expr }
+cgExpr (StgLetNoEscape _ _ binds expr) =
+  do { us <- newUniqSupply
+     ; let join_id = mkBlockId (uniqFromSupply us)
+     ; cgLneBinds join_id binds
+     ; cgExpr expr 
+     ; emit $ mkLabel join_id}
 
 cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
   cgCase expr bndr srt alt_type alts
@@ -84,37 +90,42 @@ bound only to stable things like stack locations..  The 'e' part will
 execute *next*, just like the scrutinee of a case. -}
 
 -------------------------
-cgLneBinds :: StgBinding -> FCode ()
-cgLneBinds (StgNonRec bndr rhs)
-  = do	{ local_cc <- saveCurrentCostCentre
-		-- See Note [Saving the current cost centre]
-	; info <- cgLetNoEscapeRhs local_cc bndr rhs 
-	; addBindC (cg_id info) info }
-
-cgLneBinds (StgRec pairs)
-  = do	{ local_cc <- saveCurrentCostCentre
-	; new_bindings <- fixC (\ new_bindings -> do
-		{ addBindsC new_bindings
-		; listFCs [ cgLetNoEscapeRhs local_cc b e 
-			  | (b,e) <- pairs ] })
-
-	; addBindsC new_bindings }
+cgLneBinds :: BlockId -> StgBinding -> FCode ()
+cgLneBinds join_id (StgNonRec bndr rhs)
+  = do  { local_cc <- saveCurrentCostCentre
+                -- See Note [Saving the current cost centre]
+        ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs 
+        ; addBindC (cg_id info) info }
+
+cgLneBinds join_id (StgRec pairs)
+  = do  { local_cc <- saveCurrentCostCentre
+        ; new_bindings <- fixC (\ new_bindings -> do
+                { addBindsC new_bindings
+                ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e 
+                          | (b,e) <- pairs ] })
+        ; addBindsC new_bindings }
 
 
 -------------------------
-cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
-    :: Maybe LocalReg	-- Saved cost centre
+cgLetNoEscapeRhs
+    :: BlockId          -- join point for successor of let-no-escape
+    -> Maybe LocalReg	-- Saved cost centre
     -> Id
     -> StgRhs
     -> FCode CgIdInfo
 
-cgLetNoEscapeRhs local_cc bndr rhs =
+cgLetNoEscapeRhs join_id local_cc bndr rhs =
   do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs 
      ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
-     ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
+     ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
      ; return info
      }
 
+cgLetNoEscapeRhsBody
+    :: Maybe LocalReg	-- Saved cost centre
+    -> Id
+    -> StgRhs
+    -> FCode CgIdInfo
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 713857929a..676aa4f4aa 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -437,7 +437,7 @@ do_checks :: Bool       -- Should we check the stack?
 do_checks checkStack alloc do_gc
   = withFreshLabel "gc" $ \ loop_id ->
     withFreshLabel "gc" $ \ gc_id   ->
-      mkLabel loop_id emptyStackInfo
+      mkLabel loop_id 
       <*> (let hpCheck = if alloc == 0 then mkNop
                          else mkAssign hpReg bump_hp <*>
                               mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
@@ -445,7 +445,7 @@ do_checks checkStack alloc do_gc
                 mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
               else hpCheck)
       <*> mkComment (mkFastString "outOfLine should follow:")
-      <*> outOfLine (mkLabel gc_id emptyStackInfo
+      <*> outOfLine (mkLabel gc_id 
                      <*> mkComment (mkFastString "outOfLine here")
                      <*> do_gc
                      <*> mkBranch loop_id)
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 5daceedc43..dbc97d49d8 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -80,7 +80,7 @@ emitReturn :: [CmmExpr] -> FCode ()
 emitReturn results
   = do { sequel    <- getSequel;
        ; updfr_off <- getUpdFrameOff
-       ; emit $ mkComment $ mkFastString "emitReturn"
+       ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
        ; case sequel of
            Return _ ->
              do { adjustHpBackwards
@@ -97,7 +97,7 @@ emitCall conv fun args
   = do	{ adjustHpBackwards
 	; sequel <- getSequel
 	; updfr_off <- getUpdFrameOff
-        ; emit $ mkComment $ mkFastString "emitCall"
+        ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
 	; case sequel of
 	    Return _            -> emit (mkForeignJump conv fun args updfr_off)
 	    AssignTo res_regs _ -> emit (mkCall fun conv res_regs args updfr_off)
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index c1f743dc56..1419773ce0 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -213,6 +213,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 +507,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,8 +601,8 @@ 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 } }
 
@@ -630,5 +633,5 @@ getCmm code
 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
 cgStmtsToBlocks stmts
   = do  { us <- newUniqSupply
-	; return (initUs_ us (lgraphOfAGraph 0 stmts)) }	
+	; return (initUs_ us (lgraphOfAGraph stmts)) }	
 
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index dc7fb8b9d1..f49c266499 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -52,7 +52,6 @@ import BlockId
 import Cmm
 import CmmExpr
 import MkZipCfgCmm
-import ZipCfg hiding (last, unzip, zip)
 import CLabel
 import CmmUtils
 import PprCmm		( {- instances -} )
@@ -636,7 +635,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
     mk_switch tag_expr' (sortLe le branches) mb_deflt 
 	      lo_tag hi_tag via_C
 	  -- Sort the branches before calling mk_switch
-    <*> mkLabel join_lbl emptyStackInfo
+    <*> mkLabel join_lbl
 
   where
     (t1,_) `le` (t2,_) = t1 <= t2
@@ -791,7 +790,7 @@ mkCmmLitSwitch scrut  branches deflt
     label_code join_lbl deflt		$ \ deflt ->
     label_branches join_lbl branches	$ \ branches ->
     mk_lit_switch scrut' deflt (sortLe le branches)
-    <*> mkLabel join_lbl emptyStackInfo
+    <*> mkLabel join_lbl
   where
     le (t1,_) (t2,_) = t1 <= t2
 
@@ -850,7 +849,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
 --  [L: code; goto J] fun L
 label_code join_lbl code thing_inside
   = withFreshLabel "switch" 	$ \lbl -> 
-    outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
+    outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
     <*> thing_inside lbl