X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmm.hs;h=27bf8d6bd67b0b69d031bd95efb5e1a245eae20b;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=00d93b01f1e3e81429e458b345ed24e3fcd790d4;hpb=98037604b0b148ce26ddc07a6fc6f15b4b386224;p=ghc-hetmet.git

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 00d93b0..27bf8d6 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -7,17 +7,20 @@
 -----------------------------------------------------------------------------
 
 module Cmm ( 
-	GenCmm(..), Cmm,
-	GenCmmTop(..), CmmTop,
-	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
-	CmmStmt(..), CmmActuals, CmmFormals,
+	GenCmm(..), Cmm, RawCmm,
+	GenCmmTop(..), CmmTop, RawCmmTop,
+	CmmInfo(..), UpdateFrame(..),
+        CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
+	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
+	CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
+        CmmSafety(..),
 	CmmCallTarget(..),
 	CmmStatic(..), Section(..),
 	CmmExpr(..), cmmExprRep, 
 	CmmReg(..), cmmRegRep,
 	CmmLit(..), cmmLitRep,
-	LocalReg(..), localRegRep,
-	BlockId(..),
+	LocalReg(..), localRegRep, localRegGCFollow, Kind(..),
+	BlockId(..), BlockEnv,
 	GlobalReg(..), globalRegRep,
 
 	node, nodeReg, spReg, hpReg, spLimReg
@@ -28,7 +31,10 @@ module Cmm (
 import MachOp
 import CLabel
 import ForeignCall
+import SMRep
+import ClosureInfo
 import Unique
+import UniqFM
 import FastString
 
 import Data.Word
@@ -47,17 +53,21 @@ import Data.Word
 --   (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively,
 --   (b) Native code, populated with instructions
 --
-newtype GenCmm d i = Cmm [GenCmmTop d i]
+newtype GenCmm d h i = Cmm [GenCmmTop d h i]
 
-type Cmm = GenCmm CmmStatic CmmStmt
+-- | Cmm with the info table as a data type
+type Cmm = GenCmm CmmStatic CmmInfo CmmStmt
+
+-- | Cmm with the info tables converted to a list of 'CmmStatic'
+type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt
 
 -- A top-level chunk, abstracted over the type of the contents of
 -- the basic blocks (Cmm or instructions are the likely instantiations).
-data GenCmmTop d i
+data GenCmmTop d h i
   = CmmProc
-     [d]	       -- Info table, may be empty
+     h	               -- Extra header such as the info table
      CLabel            -- Used to generate both info & entry labels
-     [LocalReg]        -- Argument locals live on entry (C-- procedure params)
+     CmmFormals        -- Argument locals live on entry (C-- procedure params)
      [GenBasicBlock i] -- Code, may be empty.  The first block is
                        -- the entry point.  The order is otherwise initially 
                        -- unimportant, but at some point the code gen will
@@ -70,7 +80,8 @@ data GenCmmTop d i
   -- some static data.
   | CmmData Section [d]	-- constant values only
 
-type CmmTop = GenCmmTop CmmStatic CmmStmt
+type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt
+type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt
 
 -- A basic block containing a single label, at the beginning.
 -- The list of basic blocks in a top-level code block may be re-ordered.
@@ -94,6 +105,58 @@ blockId (BasicBlock blk_id _ ) = blk_id
 blockStmts :: GenBasicBlock i -> [i]
 blockStmts (BasicBlock _ stmts) = stmts
 
+mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
+
+-----------------------------------------------------------------------------
+--     Info Tables
+-----------------------------------------------------------------------------
+
+data CmmInfo
+  = CmmInfo
+      (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
+      (Maybe UpdateFrame) -- Update frame
+      CmmInfoTable -- Info table
+
+-- Info table as a haskell data type
+data CmmInfoTable
+  = CmmInfoTable
+      ProfilingInfo
+      ClosureTypeTag -- Int
+      ClosureTypeInfo
+  | CmmNonInfoTable   -- Procedure doesn't need an info table
+
+-- TODO: The GC target shouldn't really be part of CmmInfo
+-- as it doesn't appear in the resulting info table.
+-- It should be factored out.
+
+data ClosureTypeInfo
+  = ConstrInfo ClosureLayout ConstrTag ConstrDescription
+  | FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry
+  | ThunkInfo ClosureLayout C_SRT
+  | ThunkSelectorInfo SelectorOffset C_SRT
+  | ContInfo
+      [Maybe LocalReg]  -- Forced stack parameters
+      C_SRT
+
+-- TODO: These types may need refinement
+data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
+type ClosureTypeTag = StgHalfWord
+type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
+type ConstrTag = StgHalfWord
+type ConstrDescription = CmmLit
+type FunType = StgHalfWord
+type FunArity = StgHalfWord
+type SlowEntry = CmmLit
+  -- ^We would like this to be a CLabel but
+  -- for now the parser sets this to zero on an INFO_TABLE_FUN.
+type SelectorOffset = StgWord
+
+-- | A frame that is to be pushed before entry to the function.
+-- Used to handle 'update' frames.
+data UpdateFrame =
+    UpdateFrame
+      CmmExpr    -- Frame header.  Behaves like the target of a 'jump'.
+      [CmmExpr]  -- Frame remainder.  Behaves like the arguments of a 'jump'.
 
 -----------------------------------------------------------------------------
 --		CmmStmt
@@ -113,12 +176,9 @@ data CmmStmt
 
   | CmmCall	 		 -- A foreign call, with 
      CmmCallTarget
-     CmmFormals			 -- zero or more results
+     CmmHintFormals		 -- zero or more results
      CmmActuals			 -- zero or more arguments
-     (Maybe [GlobalReg])	 -- Global regs that may need to be saved
-				 -- if they will be clobbered by the call.
-				 -- Nothing <=> save *all* globals that
-				 -- might be clobbered.
+     CmmSafety			 -- whether to build a continuation
 
   | CmmBranch BlockId             -- branch to another BB in this fn
 
@@ -131,13 +191,17 @@ data CmmStmt
 	-- Undefined outside range, and when there's a Nothing
 
   | CmmJump CmmExpr               -- Jump to another function,
-    CmmActuals                    -- with these parameters.
+      CmmActuals                  -- with these parameters.
 
   | CmmReturn                     -- Return from a function,
-    CmmActuals                    -- with these return values.
+      CmmActuals                  -- with these return values.
 
-type CmmActuals = [(CmmExpr,MachHint)]
-type CmmFormals = [(CmmReg,MachHint)]
+type CmmActual = CmmExpr
+type CmmActuals = [(CmmActual,MachHint)]
+type CmmFormal = LocalReg
+type CmmHintFormals = [(CmmFormal,MachHint)]
+type CmmFormals = [CmmFormal]
+data CmmSafety = CmmUnsafe | CmmSafe C_SRT
 
 {-
 Discussion
@@ -224,17 +288,25 @@ cmmRegRep :: CmmReg -> MachRep
 cmmRegRep (CmmLocal  reg) 	= localRegRep reg
 cmmRegRep (CmmGlobal reg)	= globalRegRep reg
 
+-- | Whether a 'LocalReg' is a GC followable pointer
+data Kind = KindPtr | KindNonPtr deriving (Eq)
+
 data LocalReg
-  = LocalReg !Unique MachRep
+  = LocalReg
+      !Unique   -- ^ Identifier
+      MachRep   -- ^ Type
+      Kind      -- ^ Should the GC follow as a pointer
 
 instance Eq LocalReg where
-  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+  (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
 
 instance Uniquable LocalReg where
-  getUnique (LocalReg uniq _) = uniq
+  getUnique (LocalReg uniq _ _) = uniq
 
 localRegRep :: LocalReg -> MachRep
-localRegRep (LocalReg _ rep) = rep
+localRegRep (LocalReg _ rep _) = rep
+
+localRegGCFollow (LocalReg _ _ p) = p
 
 data CmmLit
   = CmmInt Integer  MachRep
@@ -275,6 +347,8 @@ newtype BlockId = BlockId Unique
 instance Uniquable BlockId where
   getUnique (BlockId u) = u
 
+type BlockEnv a = UniqFM {- BlockId -} a
+
 -----------------------------------------------------------------------------
 --		Static Data
 -----------------------------------------------------------------------------