X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmExpr.hs;h=df6e8a1a479e8308b912fb03b64139ffea50c020;hb=31a9d04804d9cacda35695c5397590516b964964;hp=3b6aac97906c589c86bc6f659f998060df7ca929;hpb=6bc92166180824bf046d31e378359e3c386150f9;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 3b6aac9..df6e8a1 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)
@@ -396,7 +407,7 @@ cgAltRhss gc_plan bndr alts
     cg_alt (con, bndrs, _uses, rhs)
       = getCodeR		  $
 	maybeAltHeapCheck gc_plan $
-	do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs
+	do { bindConArgs con base_reg bndrs
 	   ; cgExpr rhs
 	   ; return con }
 
@@ -442,8 +453,9 @@ cgLneJump blk_id lne_regs args	-- Join point; discard sequel
 		<*> mkBranch blk_id) }
     
 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
-cgTailCall fun_id fun_info args
-  = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
+cgTailCall fun_id fun_info args = do
+    dflags <- getDynFlags
+    case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of
 
 	    -- A value in WHNF, so we can just return it.
       	ReturnIt -> emitReturn [fun]	-- ToDo: does ReturnIt guarantee tagged?