X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgClosure.lhs;h=b7360c889382eace7279068806e5cd60a893a2f4;hb=d76b6a05ab36066e8aeb67d58e25992d1ef83a8a;hp=fd851157d7f05d8a4de247518512fb1b7d945b2a;hpb=b1ab4b8a607addc4d097588db5761313c996a41f;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index fd85115..b7360c8 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -9,6 +9,13 @@ with {\em closures} on the RHSs of let(rec)s.  See also
 @CgCon@, which deals with constructors.
 
 \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 CgClosure ( cgTopRhsClosure, 
 		   cgStdRhsClosure, 
 		   cgRhsClosure,
@@ -46,6 +53,8 @@ import BasicTypes
 import Constants
 import Outputable
 import FastString
+
+import Data.List
 \end{code}
 
 %********************************************************
@@ -61,17 +70,16 @@ They should have no free variables.
 cgTopRhsClosure :: Id
 		-> CostCentreStack	-- Optional cost centre annotation
 		-> StgBinderInfo
-		-> SRT
 		-> UpdateFlag
 		-> [Id]		-- Args
 		-> StgExpr
 		-> FCode (Id, CgIdInfo)
 
-cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+cgTopRhsClosure id ccs binder_info upd_flag args body = do
   {	-- LAY OUT THE OBJECT
     let name = idName id
   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
-  ; srt_info <- getSRTInfo name srt
+  ; srt_info <- getSRTInfo
   ; mod_name <- getModuleName
   ; let descr         = closureDescription mod_name name
 	closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
@@ -136,14 +144,13 @@ Here's the general case.
 cgRhsClosure	:: Id
 		-> CostCentreStack	-- Optional cost centre annotation
 		-> StgBinderInfo
-		-> SRT
 		-> [Id]			-- Free vars
 		-> UpdateFlag
 		-> [Id]			-- Args
 		-> StgExpr
 		-> FCode (Id, CgIdInfo)
 
-cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
+cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
   { 	-- LAY OUT THE OBJECT
 	-- If the binder is itself a free variable, then don't store
 	-- it in the closure.  Instead, just bind it to Node on entry.
@@ -161,7 +168,7 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
 
   ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
   ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
-  ; srt_info <- getSRTInfo name srt
+  ; srt_info <- getSRTInfo
   ; mod_name <- getModuleName
   ; let	bind_details :: [(CgIdInfo, VirtualHpOffset)]
 	(tot_wds, ptr_wds, bind_details) 
@@ -177,7 +184,14 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
 	-- BUILD ITS INFO TABLE AND CODE
   ; forkClosureBody (do
 	{	-- Bind the fvs
-	  let bind_fv (info, offset) 
+	  let 
+              -- A function closure pointer may be tagged, so we
+              -- must take it into account when accessing the free variables.
+              mbtag       = tagForArity (length args)
+              bind_fv (info, offset)
+                | Just tag <- mbtag
+                = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
+                | otherwise
 		= bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
 	; mapCs bind_fv bind_details
 
@@ -236,7 +250,7 @@ NB: Thunks cannot have a primitive type!
 closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
   { body_absC <- getCgStmts $ do
 	{ tickyEnterThunk cl_info
-	; ldvEnter (CmmReg nodeReg)  -- NB: Node always points when profiling
+	; ldvEnterClosure cl_info  -- NB: Node always points when profiling
 	; thunkWrapper cl_info $ do
 		-- We only enter cc after setting up update so
 		-- that cc of enclosing scope will be recorded
@@ -400,8 +414,19 @@ funWrapper :: ClosureInfo 	-- Closure whose code body this is
 funWrapper closure_info arg_regs reg_save_code fun_body = do
   { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
 
+  {-
+        -- Debugging: check that R1 has the correct tag
+  ; let tag = funTag closure_info
+  ; whenC (tag /= 0 && node_points) $ do
+        l <- newLabelC
+        stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
+                                                   CmmLit (mkIntCLit tag)]) l)
+        stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
+        labelC l
+  -}
+
    	-- Enter for Ldv profiling
-  ; whenC node_points (ldvEnter (CmmReg nodeReg))
+  ; whenC node_points (ldvEnterClosure closure_info)
 
 	-- GranSim yeild poin
   ; granYield arg_regs node_points
@@ -535,7 +560,7 @@ link_caf cl_info is_upd = do
 	-- so that the garbage collector can find them
 	-- This must be done *before* the info table pointer is overwritten, 
 	-- because the old info table ptr is needed for reversion
-  ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
+  ; emitRtsCallWithVols SLIT("newCAF") [CmmHinted (CmmReg nodeReg) PtrHint] [node] False
 	-- node is live, so save it.
 
 	-- Overwrite the closure with a (static) indirection