X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgTailCall.lhs;h=4f890998ae186b0e77f0661ee340b21eed249b81;hb=785e4ab34b25c6f023183d6fabf5e74b27b416f9;hp=22cecb72492bfd93a51a0ff71aef4847f70dc1e2;hpb=9ff76535edb25ab7434284adddb5c64708ecb547;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 22cecb7..4f89099 100644
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -5,6 +5,13 @@
 % Code generation for tail calls.
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CgTailCall (
 	cgTailCall, performTailCall,
 	performReturn, performPrimReturn,
@@ -34,6 +41,7 @@ import Type
 import Id
 import StgSyn
 import PrimOp
+import FastString
 import Outputable
 
 import Control.Monad
@@ -102,19 +110,27 @@ performTailCall fun_info arg_amodes pending_assts
 
   | otherwise
   = do 	{ fun_amode <- idInfoToAmode fun_info
-	; let node_asst = oneStmt (CmmAssign nodeReg fun_amode)
+	; let assignSt  = CmmAssign nodeReg fun_amode
+              node_asst = oneStmt assignSt
 	      opt_node_asst | nodeMustPointToIt lf_info = node_asst
 			    | otherwise		        = noStmts
 	; EndOfBlockInfo sp _ <- getEndOfBlockInfo
 	; this_pkg <- getThisPackage
 
-	; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of
+	; case (getCallMethod fun_name fun_has_cafs lf_info (length arg_amodes)) of
 
 	    -- Node must always point to things we enter
 	    EnterIt -> do
 		{ emitSimultaneously (node_asst `plusStmts` pending_assts) 
-		; let target = entryCode (closureInfoPtr (CmmReg nodeReg))
-		; doFinalJump sp False (stmtC (CmmJump target [])) }
+		; let target     = entryCode (closureInfoPtr (CmmReg nodeReg))
+                      enterClosure = stmtC (CmmJump target [])
+                      -- If this is a scrutinee
+                      -- let's check if the closure is a constructor
+                      -- so we can directly jump to the alternatives switch
+                      -- statement.
+                      jumpInstr = getEndOfBlockInfo >>=
+                                  maybeSwitchOnCons enterClosure
+		; doFinalJump sp False jumpInstr }
     
 	    -- A function, but we have zero arguments.  It is already in WHNF,
 	    -- so we can just return it.  
@@ -149,6 +165,7 @@ performTailCall fun_info arg_amodes pending_assts
 
 		; directCall sp apply_lbl args extra_args 
 			(node_asst `plusStmts` pending_assts)
+
 		}
     
 	    -- A direct function call (possibly with some left-over arguments)
@@ -167,9 +184,60 @@ performTailCall fun_info arg_amodes pending_assts
 	        }
 	}
   where
-    fun_name  = idName (cgIdInfoId fun_info)
+    fun_id    = cgIdInfoId fun_info
+    fun_name  = idName fun_id
     lf_info   = cgIdInfoLF fun_info
-
+    fun_has_cafs = idCafInfo fun_id
+    untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg))
+    -- Test if closure is a constructor
+    maybeSwitchOnCons enterClosure eob
+              | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob
+              = do { is_constr <- newLabelC
+                   -- Is the pointer tagged?
+                   -- Yes, jump to switch statement
+                   ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg)) 
+                                is_constr)
+                   -- No, enter the closure.
+                   ; enterClosure
+                   ; labelC is_constr
+                   ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)) [])
+                   }
+{-
+              -- This is a scrutinee for a case expression
+              -- so let's see if we can directly inspect the closure
+              | EndOfBlockInfo _ (CaseAlts lbl _ _ _) <- eob
+              = do { no_cons <- newLabelC
+                   -- Both the NCG and gcc optimize away the temp
+                   ; z <- newTemp  wordRep
+                   ; stmtC (CmmAssign z tag_expr)
+                   ; let tag = CmmReg z
+                   -- Is the closure a cons?
+                   ; stmtC (CmmCondBranch (cond1 tag) no_cons)
+                   ; stmtC (CmmCondBranch (cond2 tag) no_cons)
+                   -- Yes, jump to switch statement
+                   ; stmtC (CmmJump (CmmLit (CmmLabel lbl)) [])
+                   ; labelC no_cons
+                   -- No, enter the closure.
+                   ; enterClosure
+                   }
+-}
+              -- No case expression involved, enter the closure.
+              | otherwise
+              = do { stmtC untag_node
+                   ; enterClosure
+                   }
+        where
+          --cond1 tag  = cmmULtWord tag lowCons
+          -- More efficient than the above?
+{-
+          tag_expr   = cmmGetClosureType (CmmReg nodeReg)
+          cond1 tag  = cmmEqWord tag (CmmLit (mkIntCLit 0))
+          cond2 tag  = cmmUGtWord tag highCons
+          lowCons    = CmmLit (mkIntCLit 1)
+            -- CONSTR
+          highCons   = CmmLit (mkIntCLit 8)
+            -- CONSTR_NOCAF_STATIC (from ClosureType.h)
+-}
 
 
 directCall sp lbl args extra_args assts = do
@@ -408,3 +476,4 @@ adjustSpAndHp newRealSp
 	; setRealHp vHp
 	}
 \end{code}
+