X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcodeGen%2FCgInfoTbls.hs;h=1780f51bb4a2cff99bd0d8321b857aec7587e6b3;hb=e2390e76b2f1f2beecd9a0d308c4890a56ae8bca;hp=f6277f1a71459743793ffb911b906748a51c49e2;hpb=1f8efd5d6214c490ef4942134abf5de9f468d29c;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index f6277f1..1780f51 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -15,6 +15,7 @@ module CgInfoTbls (
 	stdInfoTableSizeB,
 	entryCode, closureInfoPtr,
 	getConstrTag,
+        cmmGetClosureType,
 	infoTable, infoTableClosureType,
 	infoTablePtrs, infoTableNonPtrs,
 	funInfoTable, makeRelativeRefTo
@@ -60,7 +61,7 @@ emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code
 emitClosureCodeAndInfoTable cl_info args body
  = do	{ blks <- cgStmtsToBlocks body
         ; info <- mkCmmInfo cl_info
-        ; emitInfoTableAndCode info_lbl info args blks }
+        ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks }
   where
     info_lbl  = infoTableLabelFromCI cl_info
 
@@ -73,13 +74,11 @@ dataConTagZ con = dataConTag con - fIRST_TAG
 -- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
 mkCmmInfo :: ClosureInfo -> FCode CmmInfo
 mkCmmInfo cl_info = do
-  prof <- 
-      if opt_SccProfilingOn 
+  prof <-
+      if opt_SccProfilingOn
       then do ty_descr_lit <- mkStringCLit (closureTypeDescr cl_info)
               cl_descr_lit <- mkStringCLit (closureValDescr cl_info)
-              return $ ProfilingInfo
-                         (makeRelativeRefTo info_lbl ty_descr_lit)
-                         (makeRelativeRefTo info_lbl cl_descr_lit)
+              return $ ProfilingInfo ty_descr_lit cl_descr_lit
       else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
 
   case cl_info of
@@ -151,7 +150,7 @@ emitReturnTarget name stmts
                         (ProfilingInfo zeroCLit zeroCLit)
                         rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
                         (ContInfo frame srt_info))
-        ; emitInfoTableAndCode info_lbl info args blks
+        ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks
 	; return info_lbl }
   where
     args      = {- trace "emitReturnTarget: missing args" -} []
@@ -273,14 +272,24 @@ emitAlgReturnTarget
 
 emitAlgReturnTarget name branches mb_deflt fam_sz
   = do  { blks <- getCgStmts $
-		    emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
-		-- NB: tag_expr is zero-based
+                    -- is the constructor tag in the node reg?
+                    if isSmallFamily fam_sz
+                        then do -- yes, node has constr. tag
+                          let tag_expr = cmmConstrTag1 (CmmReg nodeReg)
+                              branches' = [(tag+1,branch)|(tag,branch)<-branches]
+                          emitSwitch tag_expr branches' mb_deflt 1 fam_sz
+                        else do -- no, get tag from info table
+                          let -- Note that ptr _always_ has tag 1
+                              -- when the family size is big enough
+                              untagged_ptr = cmmRegOffB nodeReg (-1)
+                              tag_expr = getConstrTag (untagged_ptr)
+                          emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
 	; lbl <- emitReturnTarget name blks
 	; return (lbl, Nothing) }
 		-- Nothing: the internal branches in the switch don't have
 		-- global labels, so we can't use them at the 'call site'
   where
-    tag_expr = getConstrTag (CmmReg nodeReg)
+    uniq = getUnique name 
 
 --------------------------------
 emitReturnInstr :: Code
@@ -346,6 +355,14 @@ getConstrTag closure_ptr
   where
     info_table = infoTable (closureInfoPtr closure_ptr)
 
+cmmGetClosureType :: CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the closure type
+-- obtained from the info table
+cmmGetClosureType closure_ptr 
+  = CmmMachOp (MO_U_Conv halfWordRep wordRep) [infoTableClosureType info_table]
+  where
+    info_table = infoTable (closureInfoPtr closure_ptr)
+
 infoTable :: CmmExpr -> CmmExpr
 -- Takes an info pointer (the first word of a closure)
 -- and returns a pointer to the first word of the standard-form
@@ -401,16 +418,14 @@ funInfoTable info_ptr
 -- put the info table next to the code
 
 emitInfoTableAndCode 
-	:: CLabel 		-- Label of info table
+	:: CLabel 		-- Label of entry or ret
 	-> CmmInfo 		-- ...the info table
 	-> CmmFormals		-- ...args
 	-> [CmmBasicBlock]	-- ...and body
 	-> Code
 
-emitInfoTableAndCode info_lbl info args blocks
-  = emitProc info entry_lbl args blocks
-  where
-	entry_lbl = infoLblToEntryLbl info_lbl
+emitInfoTableAndCode entry_ret_lbl info args blocks
+  = emitProc info entry_ret_lbl args blocks
 
 -------------------------------------------------------------------------
 --