First pass at implementing info tables for CPS

This is a fairly complete implementation, however
two 'panic's have been placed in the critical path
where the implementation is still a bit lacking so
do not expect it to run quite yet.

One call to panic is because we still need to create
a GC block for procedures that don't have them yet.
(cmm/CmmCPS.hs:continuationToProc)

The other is due to the need to convert from a
ContinuationInfo to a CmmInfo.
(codeGen/CgInfoTbls.hs:emitClosureCodeAndInfoTable)
(codeGen/CgInfoTbls.hs:emitReturnTarget)

5 files changed, 45 insertions, 13 deletions

diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index 4b659b7ebd..b0fab89f82 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -51,6 +51,7 @@ import Util
 import StaticFlags
 import FastString
 import Outputable
+import Unique
 
 import Data.Bits
 
@@ -135,7 +136,7 @@ stdPattern other = Nothing
 mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
 mkLiveness name size bits
   | size > mAX_SMALL_BITMAP_SIZE		-- Bitmap does not fit in one word
-  = do	{ let lbl = mkBitmapLabel name
+  = do	{ let lbl = mkBitmapLabel (getUnique name)
 	; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
 		             : map mkWordCLit bits)
 	; return (BigLiveness lbl) }
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 4220b47210..6b7fcd563e 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -45,6 +45,7 @@ import StaticFlags
 
 import Maybes
 import Constants
+import Panic
 
 -------------------------------------------------------------------------
 --
@@ -92,7 +93,7 @@ emitClosureCodeAndInfoTable cl_info args body
                         return (makeRelativeRefTo info_lbl cstr)
                 else return (mkIntCLit 0)
 
-	; emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
+	; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
   where
     info_lbl  = infoTableLabelFromCI cl_info
 
@@ -200,7 +201,7 @@ emitReturnTarget name stmts
 		   mkRetInfoTable info_lbl liveness srt_info cl_type
 
 	; blks <- cgStmtsToBlocks stmts
-	; emitInfoTableAndCode info_lbl std_info extra_bits args blks
+	; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks
 	; return info_lbl }
   where
     args      = {- trace "emitReturnTarget: missing args" -} []
@@ -212,7 +213,7 @@ mkRetInfoTable
   :: CLabel             -- info label
   -> Liveness		-- liveness
   -> C_SRT		-- SRT Info
-  -> Int		-- type (eg. rET_SMALL)
+  -> StgHalfWord	-- type (eg. rET_SMALL)
   -> ([CmmLit],[CmmLit])
 mkRetInfoTable info_lbl liveness srt_info cl_type
   =  (std_info, srt_slot)
@@ -264,7 +265,7 @@ emitReturnInstr
 mkStdInfoTable
    :: CmmLit		-- closure type descr (profiling)
    -> CmmLit		-- closure descr (profiling)
-   -> Int		-- closure type
+   -> StgHalfWord	-- closure type
    -> StgHalfWord	-- SRT length
    -> CmmLit		-- layout field
    -> [CmmLit]
@@ -391,6 +392,19 @@ funInfoTable info_ptr
 
 emitInfoTableAndCode 
 	:: CLabel 		-- Label of info table
+	-> 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 
+	:: CLabel 		-- Label of info table
 	-> [CmmLit]		-- ...its invariant part
 	-> [CmmLit] 		-- ...and its variant part
 	-> CmmFormals		-- ...args
@@ -415,6 +429,7 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks
 
   where
 	entry_lbl = infoLblToEntryLbl info_lbl
+-}
 
 -------------------------------------------------------------------------
 --
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index ca08e06582..e3c8a77d58 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -734,9 +734,9 @@ emitData sect lits
   where
     data_block = CmmData sect lits
 
-emitProc :: [CmmLit] -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
-emitProc lits lbl args blocks
-  = do  { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
+emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
+emitProc info lbl args blocks
+  = do  { let proc_block = CmmProc info lbl args blocks
 	; state <- getState
 	; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
@@ -745,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code
 emitSimpleProc lbl code
   = do	{ stmts <- getCgStmts code
 	; blks <- cgStmtsToBlocks stmts
-	; emitProc [] lbl [] blks }
+	; emitProc CmmNonInfo lbl [] blks }
 
 getCmm :: Code -> FCode Cmm
 -- Get all the CmmTops (there should be no stmts)
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 26857d386c..13de2136f5 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -9,7 +9,9 @@
 module CgUtils (
 	addIdReps,
 	cgLit,
-	emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
+	emitDataLits, mkDataLits,
+        emitRODataLits, mkRODataLits,
+        emitIf, emitIfThenElse,
 	emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
 	assignNonPtrTemp, newNonPtrTemp,
 	assignPtrTemp, newPtrTemp,
@@ -309,6 +311,11 @@ emitDataLits :: CLabel -> [CmmLit] -> Code
 emitDataLits lbl lits
   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+-- Emit a data-segment data block
+mkDataLits lbl lits
+  = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+
 emitRODataLits :: CLabel -> [CmmLit] -> Code
 -- Emit a read-only data block
 emitRODataLits lbl lits
@@ -319,6 +326,15 @@ emitRODataLits lbl lits
         needsRelocation (CmmLabelOff _ _) = True
         needsRelocation _                 = False
 
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits lbl lits
+  = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
+  where section | any needsRelocation lits = RelocatableReadOnlyData
+                | otherwise                = ReadOnlyData
+        needsRelocation (CmmLabel _)      = True
+        needsRelocation (CmmLabelOff _ _) = True
+        needsRelocation _                 = False
+
 mkStringCLit :: String -> FCode CmmLit
 -- Make a global definition for the string,
 -- and return its label
diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs
index 6c57a4ee67..f323c1be1d 100644
--- a/compiler/codeGen/SMRep.lhs
+++ b/compiler/codeGen/SMRep.lhs
@@ -304,7 +304,7 @@ smRepClosureType :: SMRep -> Maybe ClosureType
 smRepClosureType (GenericRep _ _ _ ty) = Just ty
 smRepClosureType BlackHoleRep	       = Nothing
 
-smRepClosureTypeInt :: SMRep -> Int
+smRepClosureTypeInt :: SMRep -> StgHalfWord
 smRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0
 smRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1
 smRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0
@@ -339,7 +339,7 @@ smRepClosureTypeInt rep = panic "smRepClosuretypeint"
 
 
 -- We export these ones
-rET_SMALL     = (RET_SMALL     :: Int)
-rET_BIG       = (RET_BIG       :: Int)
+rET_SMALL     = (RET_SMALL     :: StgHalfWord)
+rET_BIG       = (RET_BIG       :: StgHalfWord)
 \end{code}