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)

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 0918cc8..94ae64a 100644 (file)
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -213,6 +213,9 @@ data CLabel
   | LargeSRTLabel           -- Label of an StgLargeSRT
         {-# UNPACK #-} !Unique
 
   | LargeSRTLabel           -- Label of an StgLargeSRT
         {-# UNPACK #-} !Unique
 

+  | LargeBitmapLabel        -- A bitmap (function or case return)
+        {-# UNPACK #-} !Unique
+

   deriving (Eq, Ord)
 
 data IdLabelInfo
   deriving (Eq, Ord)
 
 data IdLabelInfo

@@ -225,8 +228,6 @@ data IdLabelInfo
   | RednCounts         -- Label of place to keep Ticky-ticky  info for 
                        -- this Id
 
   | RednCounts         -- Label of place to keep Ticky-ticky  info for 
                        -- this Id
 

-  | Bitmap             -- A bitmap (function or case return)
-

   | ConEntry           -- constructor entry point
   | ConInfoTable               -- corresponding info table
   | StaticConEntry     -- static constructor entry point
   | ConEntry           -- constructor entry point
   | ConInfoTable               -- corresponding info table
   | StaticConEntry     -- static constructor entry point

@@ -290,7 +291,6 @@ data DynamicLinkerLabelInfo
 -- These are always local:
 mkSRTLabel             name    = IdLabel name  SRT
 mkSlowEntryLabel       name    = IdLabel name  Slow
 -- These are always local:
 mkSRTLabel             name    = IdLabel name  SRT
 mkSlowEntryLabel       name    = IdLabel name  Slow

-mkBitmapLabel          name    = IdLabel name  Bitmap

 mkRednCountsLabel      name    = IdLabel name  RednCounts
 
 -- These have local & (possibly) external variants:
 mkRednCountsLabel      name    = IdLabel name  RednCounts
 
 -- These have local & (possibly) external variants:

@@ -335,6 +335,7 @@ mkStaticConEntryLabel this_pkg name
   | otherwise             = IdLabel name StaticConEntry
 
 mkLargeSRTLabel        uniq    = LargeSRTLabel uniq
   | otherwise             = IdLabel name StaticConEntry
 
 mkLargeSRTLabel        uniq    = LargeSRTLabel uniq

+mkBitmapLabel  uniq    = LargeBitmapLabel uniq

 
 mkReturnPtLabel uniq           = CaseLabel uniq CaseReturnPt
 mkReturnInfoLabel uniq         = CaseLabel uniq CaseReturnInfo
 
 mkReturnPtLabel uniq           = CaseLabel uniq CaseReturnPt
 mkReturnInfoLabel uniq         = CaseLabel uniq CaseReturnInfo

@@ -470,7 +471,7 @@ needsCDecl :: CLabel -> Bool
   -- they are defined before use.
 needsCDecl (IdLabel _ SRT)             = False
 needsCDecl (LargeSRTLabel _)           = False
   -- they are defined before use.
 needsCDecl (IdLabel _ SRT)             = False
 needsCDecl (LargeSRTLabel _)           = False

-needsCDecl (IdLabel _ Bitmap)          = False
+needsCDecl (LargeBitmapLabel _)                = False

 needsCDecl (IdLabel _ _)               = True
 needsCDecl (DynIdLabel _ _)            = True
 needsCDecl (CaseLabel _ _)             = True
 needsCDecl (IdLabel _ _)               = True
 needsCDecl (DynIdLabel _ _)            = True
 needsCDecl (CaseLabel _ _)             = True

@@ -550,6 +551,8 @@ labelType (CaseLabel _ CaseReturnInfo)        = DataLabel
 labelType (CaseLabel _ _)                    = CodeLabel
 labelType (ModuleInitLabel _ _ _)             = CodeLabel
 labelType (PlainModuleInitLabel _ _)          = CodeLabel
 labelType (CaseLabel _ _)                    = CodeLabel
 labelType (ModuleInitLabel _ _ _)             = CodeLabel
 labelType (PlainModuleInitLabel _ _)          = CodeLabel

+labelType (LargeSRTLabel _)                   = DataLabel
+labelType (LargeBitmapLabel _)                = DataLabel

 
 labelType (IdLabel _ info) = idInfoLabelType info
 labelType (DynIdLabel _ info) = idInfoLabelType info
 
 labelType (IdLabel _ info) = idInfoLabelType info
 labelType (DynIdLabel _ info) = idInfoLabelType info

@@ -559,7 +562,6 @@ idInfoLabelType info =
   case info of
     InfoTable            -> DataLabel
     Closure              -> DataLabel
   case info of
     InfoTable            -> DataLabel
     Closure              -> DataLabel

-    Bitmap               -> DataLabel

     ConInfoTable  -> DataLabel
     StaticInfoTable -> DataLabel
     ClosureTable  -> DataLabel
     ConInfoTable  -> DataLabel
     StaticInfoTable -> DataLabel
     ClosureTable  -> DataLabel

@@ -700,6 +702,7 @@ pprCLbl (CaseLabel u CaseDefault)
   = hcat [pprUnique u, ptext SLIT("_dflt")]
 
 pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
   = hcat [pprUnique u, ptext SLIT("_dflt")]
 
 pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")

+pprCLbl (LargeBitmapLabel u)  = pprUnique u <> pp_cSEP <> ptext SLIT("btm")

 
 pprCLbl (RtsLabel (RtsCode str))   = ptext str
 pprCLbl (RtsLabel (RtsData str))   = ptext str
 
 pprCLbl (RtsLabel (RtsCode str))   = ptext str
 pprCLbl (RtsLabel (RtsData str))   = ptext str

@@ -799,7 +802,6 @@ ppIdFlavor x = pp_cSEP <>
                       Entry            -> ptext SLIT("entry")
                       Slow             -> ptext SLIT("slow")
                       RednCounts       -> ptext SLIT("ct")
                       Entry            -> ptext SLIT("entry")
                       Slow             -> ptext SLIT("slow")
                       RednCounts       -> ptext SLIT("ct")

-                      Bitmap           -> ptext SLIT("btm")

                       ConEntry         -> ptext SLIT("con_entry")
                       ConInfoTable     -> ptext SLIT("con_info")
                       StaticConEntry   -> ptext SLIT("static_entry")
                       ConEntry         -> ptext SLIT("con_entry")
                       ConInfoTable     -> ptext SLIT("con_info")
                       StaticConEntry   -> ptext SLIT("static_entry")

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 7ec5ad0..f5525a7 100644 (file)
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -7,8 +7,9 @@
 -----------------------------------------------------------------------------
 
 module Cmm ( 
 -----------------------------------------------------------------------------
 
 module Cmm ( 

-       GenCmm(..), Cmm,
-       GenCmmTop(..), CmmTop,
+       GenCmm(..), Cmm, RawCmm,
+       GenCmmTop(..), CmmTop, RawCmmTop,
+       CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..),

        GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
        CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
        CmmCallTarget(..),
        GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
        CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
        CmmCallTarget(..),

@@ -16,7 +17,7 @@ module Cmm (
        CmmExpr(..), cmmExprRep, 
        CmmReg(..), cmmRegRep,
        CmmLit(..), cmmLitRep,
        CmmExpr(..), cmmExprRep, 
        CmmReg(..), cmmRegRep,
        CmmLit(..), cmmLitRep,

-       LocalReg(..), localRegRep, Kind(..),
+       LocalReg(..), localRegRep, localRegGCFollow, Kind(..),

        BlockId(..), BlockEnv,
        GlobalReg(..), globalRegRep,
 
        BlockId(..), BlockEnv,
        GlobalReg(..), globalRegRep,
 

@@ -28,6 +29,7 @@ module Cmm (
 import MachOp
 import CLabel
 import ForeignCall
 import MachOp
 import CLabel
 import ForeignCall

+import SMRep

 import ClosureInfo
 import Unique
 import UniqFM
 import ClosureInfo
 import Unique
 import UniqFM

@@ -49,15 +51,19 @@ import Data.Word
 --   (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively,
 --   (b) Native code, populated with instructions
 --
 --   (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).
 
 -- 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
   = CmmProc

-     [d]              -- Info table, may be empty
+     h                -- Extra header such as the info table

      CLabel            -- Used to generate both info & entry labels
      CmmFormals        -- Argument locals live on entry (C-- procedure params)
      [GenBasicBlock i] -- Code, may be empty.  The first block is
      CLabel            -- Used to generate both info & entry labels
      CmmFormals        -- Argument locals live on entry (C-- procedure params)
      [GenBasicBlock i] -- Code, may be empty.  The first block is

@@ -72,7 +78,8 @@ data GenCmmTop d i
   -- some static data.
   | CmmData Section [d]        -- constant values only
 
   -- 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.
 
 -- 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.

@@ -96,6 +103,36 @@ blockId (BasicBlock blk_id _ ) = blk_id
 blockStmts :: GenBasicBlock i -> [i]
 blockStmts (BasicBlock _ stmts) = stmts
 
 blockStmts :: GenBasicBlock i -> [i]
 blockStmts (BasicBlock _ stmts) = stmts
 

+-----------------------------------------------------------------------------
+--     Info Tables
+-----------------------------------------------------------------------------
+
+-- Info table as a haskell data type
+data CmmInfo
+  = CmmInfo
+      ProfilingInfo
+      (Maybe BlockId) -- GC target
+      ClosureTypeTag -- Int
+      ClosureTypeInfo
+  | CmmNonInfo   -- Procedure doesn't need an info table
+
+data ClosureTypeInfo
+  = ConstrInfo ClosureLayout ConstrTag ConstrDescription
+  | FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry
+  | ThunkInfo ClosureLayout 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) -- pts, nptrs
+type ConstrTag = StgHalfWord
+type ConstrDescription = CLabel
+type FunType = StgHalfWord
+type FunArity = StgHalfWord
+type SlowEntry = CLabel

 
 -----------------------------------------------------------------------------
 --             CmmStmt
 
 -----------------------------------------------------------------------------
 --             CmmStmt

diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs
index 60cb3e5..b90b1a6 100644 (file)
--- a/compiler/cmm/CmmBrokenBlock.hs
+++ b/compiler/cmm/CmmBrokenBlock.hs
@@ -37,7 +37,7 @@ data BrokenBlock
 
       brokenBlockTargets :: [BlockId],
                                 -- ^ Blocks that this block could
 
       brokenBlockTargets :: [BlockId],
                                 -- ^ Blocks that this block could

-                                -- branch to one either by conditional
+                                -- branch to either by conditional

                                 -- branches or via the last statement
 
       brokenBlockExit :: FinalStmt
                                 -- branches or via the last statement
 
       brokenBlockExit :: FinalStmt

@@ -47,6 +47,7 @@ data BrokenBlock
 -- | How a block could be entered
 data BlockEntryInfo
   = FunctionEntry              -- ^ Block is the beginning of a function
 -- | How a block could be entered
 data BlockEntryInfo
   = FunctionEntry              -- ^ Block is the beginning of a function

+      CmmInfo                   -- ^ Function header info

       CLabel                    -- ^ The function name
       CmmFormals                -- ^ Aguments to function
 
       CLabel                    -- ^ The function name
       CmmFormals                -- ^ Aguments to function
 

diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 42dfdce..f26e55f 100644 (file)
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -10,12 +10,15 @@ import Cmm
 import CmmLint
 import PprCmm
 
 import CmmLint
 import PprCmm
 

-import Dataflow

 import CmmLive
 import CmmBrokenBlock
 import CmmProcPoint
 import CmmCallConv
 import CmmLive
 import CmmBrokenBlock
 import CmmProcPoint
 import CmmCallConv

+import CmmInfo
+import CmmUtils

 
 

+import Bitmap
+import ClosureInfo

 import MachOp
 import ForeignCall
 import CLabel
 import MachOp
 import ForeignCall
 import CLabel

@@ -39,8 +42,8 @@ import Data.List
 -- |Top level driver for the CPS pass
 -----------------------------------------------------------------------------
 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
 -- |Top level driver for the CPS pass
 -----------------------------------------------------------------------------
 cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm

-       -> [Cmm]    -- ^ Input C-- with Proceedures
-       -> IO [Cmm] -- ^ Output CPS transformed C--
+       -> [GenCmm CmmStatic CmmInfo CmmStmt]    -- ^ Input C-- with Proceedures
+       -> IO [GenCmm CmmStatic [CmmStatic] CmmStmt] -- ^ Output CPS transformed C--

 cmmCPS dflags abstractC = do
   when (dopt Opt_DoCmmLinting dflags) $
        do showPass dflags "CmmLint"
 cmmCPS dflags abstractC = do
   when (dopt Opt_DoCmmLinting dflags) $
        do showPass dflags "CmmLint"

@@ -72,20 +75,21 @@ cmmCPS dflags abstractC = do
 -----------------------------------------------------------------------------
 
 cpsProc :: UniqSupply 
 -----------------------------------------------------------------------------
 
 cpsProc :: UniqSupply 

-        -> CmmTop     -- ^Input proceedure
-        -> [CmmTop]   -- ^Output proceedure and continuations
-cpsProc uniqSupply x@(CmmData _ _) = [x]
-cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
+        -> GenCmmTop CmmStatic CmmInfo CmmStmt     -- ^Input proceedure
+        -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt]   -- ^Output proceedure and continuations
+cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
+cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs

     where
     where

-      uniqes :: [[Unique]]
-      uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
+      uniques :: [[Unique]]
+      uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
+      info_uniques:block_uniques = uniques

 
       -- Break the block at each function call.
       -- The part after the function call will have to become a continuation.
       broken_blocks :: [BrokenBlock]
       broken_blocks =
 
       -- Break the block at each function call.
       -- The part after the function call will have to become a continuation.
       broken_blocks :: [BrokenBlock]
       broken_blocks =

-          concat $ zipWith3 breakBlock uniqes blocks
-                     (FunctionEntry ident params:repeat ControlEntry)
+          concat $ zipWith3 breakBlock block_uniques blocks
+                     (FunctionEntry info ident params:repeat ControlEntry)

 
       -- Calculate live variables for each broken block.
       --
 
       -- Calculate live variables for each broken block.
       --

@@ -104,20 +108,40 @@ cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
       block_env = blocksToBlockEnv broken_blocks
 
       -- Group the blocks into continuations based on the set of proc-points.
       block_env = blocksToBlockEnv broken_blocks
 
       -- Group the blocks into continuations based on the set of proc-points.

-      continuations :: [Continuation]
+      continuations :: [Continuation (Either C_SRT CmmInfo)]

       continuations = map (gatherBlocksIntoContinuation proc_points block_env)
                           (uniqSetToList proc_points)
 
       -- Select the stack format on entry to each continuation.
       continuations = map (gatherBlocksIntoContinuation proc_points block_env)
                           (uniqSetToList proc_points)
 
       -- Select the stack format on entry to each continuation.

+      -- Return the max stack offset and an association list

       --
       -- This is an association list instead of a UniqFM because
       -- CLabel's don't have a 'Uniqueable' instance.
       --
       -- This is an association list instead of a UniqFM because
       -- CLabel's don't have a 'Uniqueable' instance.

-      formats :: [(CLabel, StackFormat)]
+      formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]

       formats = selectStackFormat live continuations
 
       formats = selectStackFormat live continuations
 

+      -- Do a little meta-processing on the stack formats such as
+      -- getting the individual frame sizes and the maximum frame size
+      formats' :: (WordOff, [(CLabel, StackFormat)])
+      formats' = processFormats formats
+
+      -- TODO FIXME NOW: calculate a real max stack (including function call args)
+      -- TODO: from the maximum frame size get the maximum stack size.
+      -- The difference is due to the size taken by function calls.
+
+      -- Update the info table data on the continuations with
+      -- the selected stack formats.
+      continuations' :: [Continuation CmmInfo]
+      continuations' = map (applyStackFormat (snd formats')) continuations
+

       -- Do the actual CPS transform.
       cps_procs :: [CmmTop]
       -- Do the actual CPS transform.
       cps_procs :: [CmmTop]

-      cps_procs = map (continuationToProc formats) continuations
+      cps_procs = map (continuationToProc formats') continuations'
+
+      -- Convert the info tables from CmmInfo to [CmmStatic]
+      -- We might want to put this in another pass eventually
+      info_procs :: [RawCmmTop]
+      info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)

 
 --------------------------------------------------------------------------------
 
 
 --------------------------------------------------------------------------------
 

@@ -136,14 +160,14 @@ cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
 -- and heap memory (not sure if that's usefull at all though, but it may
 -- be worth exploring the design space).
 
 -- and heap memory (not sure if that's usefull at all though, but it may
 -- be worth exploring the design space).
 

-continuationLabel (Continuation _ _ l _ _) = l
-data Continuation =
+continuationLabel (Continuation _ l _ _) = l
+data Continuation info =

   Continuation
   Continuation

-     Bool              -- True => Function entry, False => Continuation/return point
-     [CmmStatic]       -- Info table, may be empty
+     info --(Either C_SRT CmmInfo)   -- Left <=> Continuation created by the CPS
+                       -- Right <=> Function or Proc point

      CLabel            -- Used to generate both info & entry labels
      CmmFormals        -- Argument locals live on entry (C-- procedure params)
      CLabel            -- Used to generate both info & entry labels
      CmmFormals        -- Argument locals live on entry (C-- procedure params)

-     [BrokenBlock]   -- Code, may be empty.  The first block is
+     [BrokenBlock]     -- 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
                        -- fix the order.
                        -- the entry point.  The order is otherwise initially 
                        -- unimportant, but at some point the code gen will
                        -- fix the order.

@@ -152,13 +176,11 @@ data Continuation =
                       -- to a label.  To jump to the first block in a Proc,
                       -- use the appropriate CLabel.
 
                       -- to a label.  To jump to the first block in a Proc,
                       -- use the appropriate CLabel.
 

--- Describes the layout of a stack frame for a continuation

 data StackFormat
     = StackFormat {
          stack_label :: Maybe CLabel,  -- The label occupying the top slot
          stack_frame_size :: WordOff,  -- Total frame size in words (not including arguments)
 data StackFormat
     = StackFormat {
          stack_label :: Maybe CLabel,  -- The label occupying the top slot
          stack_frame_size :: WordOff,  -- Total frame size in words (not including arguments)

-         stack_live :: [(LocalReg, WordOff)]   -- local reg offsets from stack top
-                       -- TODO: see if the above can be LocalReg
+         stack_live :: [Maybe LocalReg]        -- local reg offsets from stack top

       }
 
 -- A block can be a continuation of a call
       }
 
 -- A block can be a continuation of a call

@@ -191,70 +213,139 @@ collectNonProcPointTargets proc_points blocks current_targets block =
 
 gatherBlocksIntoContinuation ::
     UniqSet BlockId -> BlockEnv BrokenBlock
 
 gatherBlocksIntoContinuation ::
     UniqSet BlockId -> BlockEnv BrokenBlock

-    -> BlockId -> Continuation
+    -> BlockId -> Continuation (Either C_SRT CmmInfo)

 gatherBlocksIntoContinuation proc_points blocks start =
 gatherBlocksIntoContinuation proc_points blocks start =

-  Continuation is_entry info_table clabel params body
+  Continuation info_table clabel params body

     where
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
       body = start_block : children_blocks
     where
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
       start_block = lookupWithDefaultUFM blocks (panic "TODO") start
       children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
       body = start_block : children_blocks

-      info_table = [] -- TODO
+
+      -- We can't properly annotate the continuation's stack parameters
+      -- at this point because this is before stack selection
+      -- but we want to keep the C_SRT around so we use 'Either'.
+      info_table = case start_block_entry of
+                     FunctionEntry info _ _ -> Right info
+                     ContinuationEntry _ srt -> Left srt
+                     ControlEntry -> Right CmmNonInfo
+

       start_block_entry = brokenBlockEntry start_block
       start_block_entry = brokenBlockEntry start_block

-      is_entry = case start_block_entry of
-                   FunctionEntry _ _ -> True
-                   _ -> False

       clabel = case start_block_entry of
       clabel = case start_block_entry of

-                 FunctionEntry label _ -> label
+                 FunctionEntry _ label _ -> label

                  _ -> mkReturnPtLabel $ getUnique start
       params = case start_block_entry of
                  _ -> mkReturnPtLabel $ getUnique start
       params = case start_block_entry of

-                 FunctionEntry _ args -> args
+                 FunctionEntry _ _ args -> args

                  ContinuationEntry args _ -> args
                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 
 --------------------------------------------------------------------------------
 -- For now just select the continuation orders in the order they are in the set with no gaps
 
                  ContinuationEntry args _ -> args
                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 
 --------------------------------------------------------------------------------
 -- For now just select the continuation orders in the order they are in the set with no gaps
 

-selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
+selectStackFormat :: BlockEnv CmmLive
+                  -> [Continuation (Either C_SRT CmmInfo)]
+                  -> [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]

 selectStackFormat live continuations =
     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
     where
 selectStackFormat live continuations =
     map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
     where

-      selectStackFormat' (Continuation True info_table label formals blocks) =
-          StackFormat (Just label) 0 []
-      selectStackFormat' (Continuation False info_table label formals blocks) =
+      selectStackFormat' (Continuation
+                          (Right (CmmInfo _ _ _ (ContInfo format srt)))
+                          label _ _) = (Just label, format)
+      selectStackFormat' (Continuation (Right _) _ _ _) = (Nothing, [])
+      selectStackFormat' (Continuation (Left srt) label _ blocks) =

           -- TODO: assumes the first block is the entry block
           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
           -- TODO: assumes the first block is the entry block
           let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this

-          in live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
+          in (Just label,
+              map Just $ uniqSetToList $
+              lookupWithDefaultUFM live unknown_block ident)

 
 

-      live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
-      live_to_format label formals live =
-          foldl extend_format
-                    (StackFormat (Just label) retAddrSizeW [])
-                    (uniqSetToList (live `minusUniqSet` mkUniqSet formals))
+      unknown_block = panic "unknown BlockId in selectStackFormat"

 
 

-      extend_format :: StackFormat -> LocalReg -> StackFormat
-      extend_format (StackFormat label size offsets) reg =
-          StackFormat label (slot_size reg + size) ((reg, size) : offsets)
+processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
+               -> (WordOff, [(CLabel, StackFormat)])
+processFormats formats = (max_size, formats')
+    where
+      max_size = foldl max 0 (map (stack_frame_size . snd) formats')
+      formats' = map make_format formats
+      make_format (label, format) =
+          (label,
+           StackFormat {
+             stack_label = fst format,
+             stack_frame_size = stack_size (snd format) +
+                                if isJust (fst format)
+                                then label_size
+                                else 0,
+             stack_live = snd format })
+
+      -- TODO: get rid of "+ 1" etc.
+      label_size = 1 :: WordOff
+
+      stack_size [] = 0
+      stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
+      stack_size (Just reg:formats) = width + stack_size formats
+          where
+            width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+            -- TODO: it would be better if we had a machRepWordWidth

 
 

-      slot_size :: LocalReg -> Int
-      slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
+-----------------------------------------------------------------------------
+applyStackFormat :: [(CLabel, StackFormat)]
+                 -> Continuation (Either C_SRT CmmInfo)
+                 -> Continuation CmmInfo
+
+-- User written continuations
+applyStackFormat formats (Continuation
+                          (Right (CmmInfo prof gc tag (ContInfo _ srt)))
+                          label formals blocks) =
+    Continuation (CmmInfo prof gc tag (ContInfo format srt))
+                 label formals blocks
+    where
+      format = stack_live $ maybe unknown_block id $ lookup label formats
+      unknown_block = panic "unknown BlockId in applyStackFormat"

 
 

-      unknown_block = panic "unknown BlockId in selectStackFormat"
+-- User written non-continuation code
+applyStackFormat formats (Continuation (Right info) label formals blocks) =
+    Continuation info label formals blocks

 
 

-continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
-continuationToProc formats (Continuation is_entry info label formals blocks) =
-    CmmProc info label formals (map (continuationToProc' label formats) blocks)
+-- CPS generated continuations
+applyStackFormat formats (Continuation (Left srt) label formals blocks) =
+    Continuation (CmmInfo prof gc tag (ContInfo (stack_live $ format) srt))
+                 label formals blocks

     where
     where

-      continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
-                             -> CmmBasicBlock
-      continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
+      gc = Nothing -- Generated continuations never need a stack check
+      -- TODO prof: this is the same as the current implementation
+      -- but I think it could be improved
+      prof = ProfilingInfo zeroCLit zeroCLit
+      tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
+            then rET_BIG
+            else rET_SMALL
+      format = maybe unknown_block id $ lookup label formats
+      unknown_block = panic "unknown BlockId in applyStackFormat"
+
+-----------------------------------------------------------------------------
+continuationToProc :: (WordOff, [(CLabel, StackFormat)])
+                   -> Continuation CmmInfo
+                   -> CmmTop
+continuationToProc (max_stack, formats)
+                   (Continuation info label formals blocks) =
+    CmmProc info label formals (map continuationToProc' blocks)
+    where
+      curr_format = maybe unknown_block id $ lookup label formats
+      unknown_block = panic "unknown BlockId in continuationToProc"
+
+      continuationToProc' :: BrokenBlock -> CmmBasicBlock
+      continuationToProc' (BrokenBlock ident entry stmts _ exit) =

           BasicBlock ident (prefix++stmts++postfix)
           where
           BasicBlock ident (prefix++stmts++postfix)
           where

-            curr_format = maybe unknown_block id $ lookup curr_ident formats
-            unknown_block = panic "unknown BlockId in continuationToProc"

             prefix = case entry of
                        ControlEntry -> []
             prefix = case entry of
                        ControlEntry -> []

-                       FunctionEntry _ formals -> -- TODO: gc_stack_check
+                       FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals ->
+                           gc_stack_check gc_block max_stack ++
+                           function_entry formals curr_format
+                       FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
+                           panic "continuationToProc: TODO generate GC block" ++
+                           function_entry formals curr_format
+                       FunctionEntry CmmNonInfo _ formals ->
+                           panic "TODO: gc_stack_check gc_block max_stack" ++

                            function_entry formals curr_format
                        ContinuationEntry formals _ ->
                            function_entry formals curr_format
                            function_entry formals curr_format
                        ContinuationEntry formals _ ->
                            function_entry formals curr_format

@@ -277,7 +368,7 @@ continuationToProc formats (Continuation is_entry info label formals blocks) =
                                             lookup (mkReturnPtLabel $ getUnique next) formats
                         FinalCall next _ results arguments -> panic "unimplemented CmmCall"
 
                                             lookup (mkReturnPtLabel $ getUnique next) formats
                         FinalCall next _ results arguments -> panic "unimplemented CmmCall"
 

---------------------------------------------------------------------------------
+-----------------------------------------------------------------------------

 -- Functions that generate CmmStmt sequences
 -- for packing/unpacking continuations
 -- and entering/exiting functions
 -- Functions that generate CmmStmt sequences
 -- for packing/unpacking continuations
 -- and entering/exiting functions

@@ -298,33 +389,45 @@ tail_call spRel target arguments
 
     argument_formats = assignArguments (cmmExprRep . fst) arguments
 
 
     argument_formats = assignArguments (cmmExprRep . fst) arguments
 

-gc_stack_check :: WordOff -> [CmmStmt]
-gc_stack_check max_frame_size
+gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
+gc_stack_check gc_block max_frame_size

   = check_stack_limit where
     check_stack_limit = [
      CmmCondBranch
      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
      gc_block]
   = check_stack_limit where
     check_stack_limit = [
      CmmCondBranch
      (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
                     [CmmRegOff spReg max_frame_size, CmmReg spLimReg])
      gc_block]

-    gc_block = panic "gc_check not implemented" -- TODO: get stack and heap checks to go to same

 
 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 pack_continuation (StackFormat curr_id curr_frame_size _)
 
 -- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
 pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
 pack_continuation (StackFormat curr_id curr_frame_size _)

-                       (StackFormat cont_id cont_frame_size cont_offsets)
+                       (StackFormat cont_id cont_frame_size live_regs)

   = store_live_values ++ set_stack_header where
   = store_live_values ++ set_stack_header where

-    -- TODO: only save variables when actually needed (may be handled by latter pass)
+    -- TODO: only save variables when actually needed
+    -- (may be handled by latter pass)

     store_live_values =
         [stack_put spRel (CmmReg (CmmLocal reg)) offset
          | (reg, offset) <- cont_offsets]
     set_stack_header =
     store_live_values =
         [stack_put spRel (CmmReg (CmmLocal reg)) offset
          | (reg, offset) <- cont_offsets]
     set_stack_header =

-        if not needs_header
-        then []
-        else [stack_put spRel continuation_function 0]
+        if needs_header_set
+        then [stack_put spRel continuation_function 0]
+        else []
+
+    -- TODO: factor with function_entry and CmmInfo.hs(?)
+    cont_offsets = mkOffsets label_size live_regs
+
+    label_size = 1 :: WordOff
+
+    mkOffsets size [] = []
+    mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
+    mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
+        where
+          width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+          -- TODO: it would be better if we had a machRepWordWidth

 
     spRel = curr_frame_size - cont_frame_size
     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
 
     spRel = curr_frame_size - cont_frame_size
     continuation_function = CmmLit $ CmmLabel $ fromJust cont_id

-    needs_header =
+    needs_header_set =

         case (curr_id, cont_id) of
           (Just x, Just y) -> x /= y
           _ -> isJust cont_id
         case (curr_id, cont_id) of
           (Just x, Just y) -> x /= y
           _ -> isJust cont_id

@@ -334,9 +437,10 @@ pack_continuation (StackFormat curr_id curr_frame_size _)
 -- have the same stack format (this causes a problem
 -- only for proc-point).
 function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
 -- have the same stack format (this causes a problem
 -- only for proc-point).
 function_entry :: CmmFormals -> StackFormat -> [CmmStmt]

-function_entry formals (StackFormat _ _ curr_offsets)
+function_entry formals (StackFormat _ _ live_regs)

   = load_live_values ++ load_args where
   = load_live_values ++ load_args where

-    -- TODO: only save variables when actually needed (may be handled by latter pass)
+    -- TODO: only save variables when actually needed
+    -- (may be handled by latter pass)

     load_live_values =
         [stack_get 0 reg offset
          | (reg, offset) <- curr_offsets]
     load_live_values =
         [stack_get 0 reg offset
          | (reg, offset) <- curr_offsets]

@@ -348,6 +452,18 @@ function_entry formals (StackFormat _ _ curr_offsets)
 
     argument_formats = assignArguments (localRegRep) formals
 
 
     argument_formats = assignArguments (localRegRep) formals
 

+    -- TODO: eliminate copy/paste with pack_continuation
+    curr_offsets = mkOffsets label_size live_regs
+
+    label_size = 1 :: WordOff
+
+    mkOffsets size [] = []
+    mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
+    mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
+        where
+          width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+          -- TODO: it would be better if we had a machRepWordWidth
+

 -----------------------------------------------------------------------------
 -- Section: Stack and argument register puts and gets
 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------
 -- Section: Stack and argument register puts and gets
 -----------------------------------------------------------------------------

@@ -370,7 +486,9 @@ stack_get :: WordOff
           -> WordOff
           -> CmmStmt
 stack_get spRel reg offset =
           -> WordOff
           -> CmmStmt
 stack_get spRel reg offset =

-    CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (localRegRep reg))
+    CmmAssign (CmmLocal reg)
+              (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
+                       (localRegRep reg))

 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 global_put expr global = CmmAssign (CmmGlobal global) expr
 global_get :: LocalReg -> GlobalReg -> CmmStmt
 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 global_put expr global = CmmAssign (CmmGlobal global) expr
 global_get :: LocalReg -> GlobalReg -> CmmStmt

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index fd4a99c..130dba0 100644 (file)
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -25,10 +25,10 @@ import Control.Monad
 -- -----------------------------------------------------------------------------
 -- Exported entry points:
 
 -- -----------------------------------------------------------------------------
 -- Exported entry points:
 

-cmmLint :: Cmm -> Maybe SDoc
+cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc

 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
 
 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
 

-cmmLintTop :: CmmTop -> Maybe SDoc
+cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc

 cmmLintTop top = runCmmLint $ lintCmmTop top
 
 runCmmLint :: CmmLint a -> Maybe SDoc
 cmmLintTop top = runCmmLint $ lintCmmTop top
 
 runCmmLint :: CmmLint a -> Maybe SDoc

@@ -37,7 +37,7 @@ runCmmLint l =
        Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
        Right _  -> Nothing
 
        Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
        Right _  -> Nothing
 

-lintCmmTop (CmmProc _info lbl _args blocks)
+lintCmmTop (CmmProc _ lbl _ blocks)

   = addLintInfo (text "in proc " <> pprCLabel lbl) $
        mapM_ lintCmmBlock blocks
 lintCmmTop _other
   = addLintInfo (text "in proc " <> pprCLabel lbl) $
        mapM_ lintCmmBlock blocks
 lintCmmTop _other

diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 76ed78e..4b2a488 100644 (file)
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -531,7 +531,7 @@ narrowS _ _ = panic "narrowTo"
   except factorial, but what the hell.
 -}
 
   except factorial, but what the hell.
 -}
 

-cmmLoopifyForC :: CmmTop -> CmmTop
+cmmLoopifyForC :: RawCmmTop -> RawCmmTop

 cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
   | null info = p  -- only if there's an info table, ignore case alts
   | otherwise =  
 cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
   | null info = p  -- only if there's an info table, ignore case alts
   | otherwise =  

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index dda1ca2..ab50799 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -199,23 +199,24 @@ lits      :: { [ExtFCode CmmExpr] }
        | ',' expr lits         { $2 : $3 }
 
 cmmproc :: { ExtCode }
        | ',' expr lits         { $2 : $3 }
 
 cmmproc :: { ExtCode }

-       : info maybe_formals '{' body '}'
-               { do (info_lbl, info1, info2) <- $1;
-                    formals <- sequence $2;
-                    stmts <- getCgStmtsEC (loopDecls $4)
-                    blks <- code (cgStmtsToBlocks stmts)
-                    code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
-
-       | info maybe_formals ';'
-               { do (info_lbl, info1, info2) <- $1;
-                    formals <- sequence $2;
-                    code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
-
-       | NAME maybe_formals '{' body '}'
+-- TODO: add real SRT/info tables to parsed Cmm
+--     : info maybe_formals '{' body '}'
+--             { do (info_lbl, info1, info2) <- $1;
+--                  formals <- sequence $2;
+--                  stmts <- getCgStmtsEC (loopDecls $4)
+--                  blks <- code (cgStmtsToBlocks stmts)
+--                  code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
+--
+--     | info maybe_formals ';'
+--             { do (info_lbl, info1, info2) <- $1;
+--                  formals <- sequence $2;
+--                  code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
+
+       : NAME maybe_formals '{' body '}'

                { do formals <- sequence $2;
                     stmts <- getCgStmtsEC (loopDecls $4);
                     blks <- code (cgStmtsToBlocks stmts);
                { do formals <- sequence $2;
                     stmts <- getCgStmtsEC (loopDecls $4);
                     blks <- code (cgStmtsToBlocks stmts);

-                    code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
+                    code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }

 
 info   :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 
 info   :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'

@@ -261,13 +262,17 @@ stmt      :: { ExtCode }
        | NAME ':'
                { do l <- newLabel $1; code (labelC l) }
 
        | NAME ':'
                { do l <- newLabel $1; code (labelC l) }
 

--- HACK: this should just be lregs but that causes a shift/reduce conflict
--- with foreign calls
---     | hint_lregs '=' expr ';'
---             { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
+       | lreg '=' expr ';'
+               { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }

        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }

--- TODO: add real SRT to parsed Cmm
+
+       -- Gah! We really want to say "maybe_results" but that causes
+       -- a shift/reduce conflict with assignment.  We either
+       -- we expand out the no-result and single result cases or
+       -- we tweak the syntax to avoid the conflict.  The later
+       -- option is taken here because the other way would require
+       -- multiple levels of expanding and get unwieldy.

        | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
                {% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
        | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
        | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
                {% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
        | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'

@@ -407,15 +412,11 @@ reg       :: { ExtFCode CmmExpr }
 
 maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
        : {- empty -}           { [] }
 
 maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
        : {- empty -}           { [] }

-       | hint_lregs '='        { $1 }
-
-hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
-       : {- empty -}           { [] }
-       | hint_lregs            { $1 }
+       | '(' hint_lregs ')' '='        { $2 }

 
 hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
 
 hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }

-       : hint_lreg ','                 { [$1] }
-       | hint_lreg                     { [$1] }
+       : hint_lreg                     { [$1] }
+       | hint_lreg ','                 { [$1] }

        | hint_lreg ',' hint_lregs      { $1 : $3 }
 
 hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
        | hint_lreg ',' hint_lregs      { $1 : $3 }
 
 hint_lreg :: { ExtFCode (CmmFormal, MachHint) }

diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 65b0816..2d48f76 100644 (file)
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -45,7 +45,7 @@ calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
                          map brokenBlockId $
                          filter always_proc_point blocks
       always_proc_point BrokenBlock {
                          map brokenBlockId $
                          filter always_proc_point blocks
       always_proc_point BrokenBlock {

-                              brokenBlockEntry = FunctionEntry _ _ } = True
+                              brokenBlockEntry = FunctionEntry _ _ _ } = True

       always_proc_point BrokenBlock {
                               brokenBlockEntry = ContinuationEntry _ _ } = True
       always_proc_point _ = False
       always_proc_point BrokenBlock {
                               brokenBlockEntry = ContinuationEntry _ _ } = True
       always_proc_point _ = False

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 817e82b..8726547 100644 (file)
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -66,7 +66,7 @@ import StaticFlags    ( opt_Unregisterised )
 -- --------------------------------------------------------------------------
 -- Top level
 
 -- --------------------------------------------------------------------------
 -- Top level
 

-pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs :: DynFlags -> [RawCmm] -> SDoc

 pprCs dflags cmms
  = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
  where
 pprCs dflags cmms
  = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
  where

@@ -74,7 +74,7 @@ pprCs dflags cmms
      | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
      | otherwise                = empty
 
      | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
      | otherwise                = empty
 

-writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()

 writeCs dflags handle cmms 
   = printForC handle (pprCs dflags cmms)
 
 writeCs dflags handle cmms 
   = printForC handle (pprCs dflags cmms)
 

@@ -84,13 +84,13 @@ writeCs dflags handle cmms
 -- for fun, we could call cmmToCmm over the tops...
 --
 
 -- for fun, we could call cmmToCmm over the tops...
 --
 

-pprC :: Cmm -> SDoc
+pprC :: RawCmm -> SDoc

 pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 
 --
 -- top level procs
 -- 
 pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 
 --
 -- top level procs
 -- 

-pprTop :: CmmTop -> SDoc
+pprTop :: RawCmmTop -> SDoc

 pprTop (CmmProc info clbl _params blocks) =
     (if not (null info)
         then pprDataExterns info $$
 pprTop (CmmProc info clbl _params blocks) =
     (if not (null info)
         then pprDataExterns info $$

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 3253915..55a8014 100644 (file)
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -52,7 +52,7 @@ import Data.List
 import System.IO
 import Data.Maybe
 
 import System.IO
 import Data.Maybe
 

-pprCmms :: [Cmm] -> SDoc
+pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc

 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
         where
           separator = space $$ ptext SLIT("-------------------") $$ space
 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
         where
           separator = space $$ ptext SLIT("-------------------") $$ space

@@ -62,10 +62,10 @@ writeCmms handle cmms = printForC handle (pprCmms cmms)
 
 -----------------------------------------------------------------------------
 
 
 -----------------------------------------------------------------------------
 

-instance Outputable Cmm where
+instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where

     ppr c = pprCmm c
 
     ppr c = pprCmm c
 

-instance Outputable CmmTop where
+instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where

     ppr t = pprTop t
 
 instance Outputable CmmBasicBlock where
     ppr t = pprTop t
 
 instance Outputable CmmBasicBlock where

@@ -86,31 +86,28 @@ instance Outputable LocalReg where
 instance Outputable GlobalReg where
     ppr e = pprGlobalReg e
 
 instance Outputable GlobalReg where
     ppr e = pprGlobalReg e
 

+instance Outputable CmmStatic where
+    ppr e = pprStatic e
+
+instance Outputable CmmInfo where
+    ppr e = pprInfo e
+

 -----------------------------------------------------------------------------
 
 -----------------------------------------------------------------------------
 

-pprCmm :: Cmm -> SDoc
+pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc

 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 
 -- --------------------------------------------------------------------------
 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 
 -- --------------------------------------------------------------------------

--- Top level `procedure' blocks. The info tables, if not null, are
--- printed in the style of C--'s 'stackdata' declaration, just inside
--- the proc body, and are labelled with the procedure name ++ "_info".
+-- Top level `procedure' blocks.

 --
 --

-pprTop :: CmmTop -> SDoc
+pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc

 pprTop (CmmProc info lbl params blocks )
 
   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
 pprTop (CmmProc info lbl params blocks )
 
   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace

-         , nest 8 $ pprInfo info lbl
+         , nest 8 $ lbrace <+> ppr info $$ rbrace

          , nest 4 $ vcat (map ppr blocks)
          , rbrace ]
 
          , nest 4 $ vcat (map ppr blocks)
          , rbrace ]
 

-  where
-    pprInfo [] _  = empty
-    pprInfo i label = 
-        (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
-            4 $ vcat (map pprStatic i))
-        $$ rbrace
-

 -- --------------------------------------------------------------------------
 -- We follow [1], 4.5
 --
 -- --------------------------------------------------------------------------
 -- We follow [1], 4.5
 --

@@ -121,6 +118,46 @@ pprTop (CmmData section ds) =
     $$ rbrace
 
 
     $$ rbrace
 
 

+
+-- --------------------------------------------------------------------------
+-- Info tables. The current pretty printer needs refinement
+-- but will work for now.
+--
+-- For ideas on how to refine it, they used to be printed in the
+-- style of C--'s 'stackdata' declaration, just inside the proc body,
+-- and were labelled with the procedure name ++ "_info".
+pprInfo CmmNonInfo = empty
+pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
+                 gc_target tag info) =
+    vcat [ptext SLIT("type: ") <> pprLit closure_type,
+          ptext SLIT("desc: ") <> pprLit closure_desc,
+          ptext SLIT("gc_target: ") <>
+                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+          ptext SLIT("tag: ") <> integer (toInteger tag),
+          pprTypeInfo info]
+
+pprTypeInfo (ConstrInfo layout constr descr) =
+    vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
+          ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
+          ptext SLIT("constructor: ") <> integer (toInteger constr),
+          ppr descr]
+pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
+    vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
+          ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
+          ptext SLIT("srt: ") <> ppr srt,
+          ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
+          ptext SLIT("arity: ") <> integer (toInteger arity)
+          --ppr args, -- TODO: needs to be printed
+          --ppr slow_entry -- TODO: needs to be printed
+         ]
+pprTypeInfo (ThunkInfo layout srt) =
+    vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
+          ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
+          ptext SLIT("srt: ") <> ppr srt]
+pprTypeInfo (ContInfo stack srt) =
+    vcat [ptext SLIT("stack: ") <> ppr stack,
+          ptext SLIT("srt: ") <> ppr srt]
+

 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; .. 
 -- --------------------------------------------------------------------------
 -- Basic blocks look like assembly blocks.
 --      lbl: stmt ; stmt ; .. 

@@ -151,12 +188,13 @@ pprStmt stmt = case stmt of
     -- call "ccall" foo(x, y)[r1, r2];
     -- ToDo ppr volatile
     CmmCall (CmmForeignCall fn cconv) results args srt ->
     -- call "ccall" foo(x, y)[r1, r2];
     -- ToDo ppr volatile
     CmmCall (CmmForeignCall fn cconv) results args srt ->

-        hcat [ ptext SLIT("call"), space, 
+        hcat [ if null results
+                  then empty
+                  else parens (commafy $ map ppr results) <>
+                       ptext SLIT(" = "),
+               ptext SLIT("call"), space, 

                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),
                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),

-               (if null results
-                    then empty
-                    else brackets( commafy $ map ppr results)),

                brackets (ppr srt), semi ]
         where
             target (CmmLit lit) = pprLit lit
                brackets (ppr srt), semi ]
         where
             target (CmmLit lit) = pprLit lit

diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index 4b659b7..b0fab89 100644 (file)
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -51,6 +51,7 @@ import Util
 import StaticFlags
 import FastString
 import Outputable
 import StaticFlags
 import FastString
 import Outputable

+import Unique

 
 import Data.Bits
 
 
 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
 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) }
        ; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
                             : map mkWordCLit bits)
        ; return (BigLiveness lbl) }

diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 4220b47..6b7fcd5 100644 (file)
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -45,6 +45,7 @@ import StaticFlags
 
 import Maybes
 import Constants
 
 import Maybes
 import Constants

+import Panic

 
 -------------------------------------------------------------------------
 --
 
 -------------------------------------------------------------------------
 --

@@ -92,7 +93,7 @@ emitClosureCodeAndInfoTable cl_info args body
                         return (makeRelativeRefTo info_lbl cstr)
                 else return (mkIntCLit 0)
 
                         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
 
   where
     info_lbl  = infoTableLabelFromCI cl_info
 

@@ -200,7 +201,7 @@ emitReturnTarget name stmts
                   mkRetInfoTable info_lbl liveness srt_info cl_type
 
        ; blks <- cgStmtsToBlocks 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" -} []
        ; return info_lbl }
   where
     args      = {- trace "emitReturnTarget: missing args" -} []

@@ -212,7 +213,7 @@ mkRetInfoTable
   :: CLabel             -- info label
   -> Liveness          -- liveness
   -> C_SRT             -- SRT Info
   :: 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)
   -> ([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)
 mkStdInfoTable
    :: CmmLit           -- closure type descr (profiling)
    -> CmmLit           -- closure descr (profiling)

-   -> Int              -- closure type
+   -> StgHalfWord      -- closure type

    -> StgHalfWord      -- SRT length
    -> CmmLit           -- layout field
    -> [CmmLit]
    -> StgHalfWord      -- SRT length
    -> CmmLit           -- layout field
    -> [CmmLit]

@@ -391,6 +392,19 @@ funInfoTable info_ptr
 
 emitInfoTableAndCode 
        :: CLabel               -- Label of info table
 
 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
        -> [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
 
   where
        entry_lbl = infoLblToEntryLbl info_lbl

+-}

 
 -------------------------------------------------------------------------
 --
 
 -------------------------------------------------------------------------
 --

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index ca08e06..e3c8a77 100644 (file)
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -734,9 +734,9 @@ emitData sect lits
   where
     data_block = CmmData 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 } }
 
        ; 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
 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)
 
 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 26857d3..13de213 100644 (file)
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -9,7 +9,9 @@
 module CgUtils (
        addIdReps,
        cgLit,
 module CgUtils (
        addIdReps,
        cgLit,

-       emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
+       emitDataLits, mkDataLits,
+        emitRODataLits, mkRODataLits,
+        emitIf, emitIfThenElse,

        emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
        assignNonPtrTemp, newNonPtrTemp,
        assignPtrTemp, newPtrTemp,
        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)
 
 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
 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
 
         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
 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 6c57a4e..f323c1b 100644 (file)
--- 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
 
 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
 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
 
 
 -- 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}
 
 \end{code}
 

diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index 0e52077..a3d24e2 100644 (file)
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -26,7 +26,7 @@ import Packages
 import PackageConfig   ( rtsPackageId )
 import Util
 import FastString      ( unpackFS )
 import PackageConfig   ( rtsPackageId )
 import Util
 import FastString      ( unpackFS )

-import Cmm             ( Cmm )
+import Cmm             ( RawCmm )

 import HscTypes
 import DynFlags
 
 import HscTypes
 import DynFlags
 

@@ -55,7 +55,7 @@ codeOutput :: DynFlags
           -> ModLocation
           -> ForeignStubs
           -> [PackageId]
           -> ModLocation
           -> ForeignStubs
           -> [PackageId]

-          -> [Cmm]                     -- Compiled C--
+          -> [RawCmm]                  -- Compiled C--

           -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
 
 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
           -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
 
 codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 93324d5..0ae942c 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -605,7 +605,7 @@ hscCompile cgguts
                               foreign_stubs dir_imps cost_centre_info
                               stg_binds hpc_info
          ------------------  Convert to CPS --------------------
                               foreign_stubs dir_imps cost_centre_info
                               stg_binds hpc_info
          ------------------  Convert to CPS --------------------

-         continuationC <- cmmCPS dflags abstractC
+         continuationC <- {-return abstractC-} cmmCPS dflags abstractC

          ------------------  Code output -----------------------
          (stub_h_exists,stub_c_exists)
              <- codeOutput dflags this_mod location foreign_stubs 
          ------------------  Code output -----------------------
          (stub_h_exists,stub_c_exists)
              <- codeOutput dflags this_mod location foreign_stubs 

@@ -721,7 +721,7 @@ hscCmmFile dflags filename = do
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do
   case maybe_cmm of
     Nothing -> return False
     Just cmm -> do

-        continuationC <- cmmCPS dflags [cmm]
+        continuationC <- {-return [cmm]-} cmmCPS dflags [cmm]

        codeOutput dflags no_mod no_loc NoStubs [] continuationC
        return True
   where
        codeOutput dflags no_mod no_loc NoStubs [] continuationC
        return True
   where

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index b3ca844..f954d52 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -108,12 +108,12 @@ The machine-dependent bits break down as follows:
 
 -- NB. We *lazilly* compile each block of code for space reasons.
 
 
 -- NB. We *lazilly* compile each block of code for space reasons.
 

-nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc

 nativeCodeGen dflags cmms us
   = let (res, _) = initUs us $
           cgCmm (concat (map add_split cmms))
 
 nativeCodeGen dflags cmms us
   = let (res, _) = initUs us $
           cgCmm (concat (map add_split cmms))
 

-       cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
+       cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])

        cgCmm tops = 
           lazyMapUs (cmmNativeGen dflags) tops  `thenUs` \ results -> 
           case unzip3 results of { (cmms,docs,imps) ->
        cgCmm tops = 
           lazyMapUs (cmmNativeGen dflags) tops  `thenUs` \ results -> 
           case unzip3 results of { (cmms,docs,imps) ->

@@ -196,7 +196,7 @@ nativeCodeGen dflags cmms us
 -- Complete native code generation phase for a single top-level chunk
 -- of Cmm.
 
 -- Complete native code generation phase for a single top-level chunk
 -- of Cmm.
 

-cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
+cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])

 cmmNativeGen dflags cmm
    = {-# SCC "fixAssigns"       #-} 
        fixAssignsTop cmm            `thenUs` \ fixed_cmm ->
 cmmNativeGen dflags cmm
    = {-# SCC "fixAssigns"       #-} 
        fixAssignsTop cmm            `thenUs` \ fixed_cmm ->

@@ -390,7 +390,7 @@ apply_mapping ufm (CmmProc info lbl params blocks)
 -- Switching between the two monads whilst carrying along the same
 -- Unique supply breaks abstraction.  Is that bad?
 
 -- Switching between the two monads whilst carrying along the same
 -- Unique supply breaks abstraction.  Is that bad?
 

-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])

 
 genMachCode cmm_top
   = do { initial_us <- getUs
 
 genMachCode cmm_top
   = do { initial_us <- getUs

@@ -412,7 +412,7 @@ genMachCode cmm_top
 -- the generic optimiser below, to avoid having two separate passes
 -- over the Cmm.
 
 -- the generic optimiser below, to avoid having two separate passes
 -- over the Cmm.
 

-fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop

 fixAssignsTop top@(CmmData _ _) = returnUs top
 fixAssignsTop (CmmProc info lbl params blocks) =
   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
 fixAssignsTop top@(CmmData _ _) = returnUs top
 fixAssignsTop (CmmProc info lbl params blocks) =
   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->

@@ -490,7 +490,7 @@ Ideas for other things we could do (ToDo):
     temp assignments, and certain assigns to mem...)
 -}
 
     temp assignments, and certain assigns to mem...)
 -}
 

-cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
+cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel])

 cmmToCmm top@(CmmData _ _) = (top, [])
 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
 cmmToCmm top@(CmmData _ _) = (top, [])
 cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)

diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
index dc79d95..154eed8 100644 (file)
--- a/compiler/nativeGen/MachCodeGen.hs
+++ b/compiler/nativeGen/MachCodeGen.hs
@@ -62,7 +62,7 @@ import Data.Int
 
 type InstrBlock = OrdList Instr
 
 
 type InstrBlock = OrdList Instr
 

-cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
+cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop]

 cmmTopCodeGen (CmmProc info lab params blocks) = do
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
 cmmTopCodeGen (CmmProc info lab params blocks) = do
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat

diff --git a/compiler/nativeGen/MachInstrs.hs b/compiler/nativeGen/MachInstrs.hs
index 6316d94..5ed8c0c 100644 (file)
--- a/compiler/nativeGen/MachInstrs.hs
+++ b/compiler/nativeGen/MachInstrs.hs
@@ -52,8 +52,8 @@ import GHC.Exts
 -- Our flavours of the Cmm types
 
 -- Type synonyms for Cmm populated with native code
 -- Our flavours of the Cmm types
 
 -- Type synonyms for Cmm populated with native code

-type NatCmm        = GenCmm CmmStatic Instr
-type NatCmmTop     = GenCmmTop CmmStatic Instr
+type NatCmm        = GenCmm CmmStatic [CmmStatic] Instr
+type NatCmmTop     = GenCmmTop CmmStatic [CmmStatic] Instr

 type NatBasicBlock = GenBasicBlock Instr
 
 -- -----------------------------------------------------------------------------
 type NatBasicBlock = GenBasicBlock Instr
 
 -- -----------------------------------------------------------------------------