Remove OldCmm, convert backends to consume new Cmm
authorSimon Marlow <marlowsd@gmail.com>
Mon, 12 Nov 2012 11:47:51 +0000 (11:47 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 12 Nov 2012 15:20:25 +0000 (15:20 +0000)
This removes the OldCmm data type and the CmmCvt pass that converts
new Cmm to OldCmm.  The backends (NCGs, LLVM and C) have all been
converted to consume new Cmm.

The main difference between the two data types is that conditional
branches in new Cmm have both true/false successors, whereas in OldCmm
the false case was a fallthrough.  To generate slightly better code we
occasionally need to invert a conditional to ensure that the
branch-not-taken becomes a fallthrough; this was previously done in
CmmCvt, and it is now done in CmmContFlowOpt.

We could go further and use the Hoopl Block representation for native
code, which would mean that we could use Hoopl's postorderDfs and
analyses for native code, but for now I've left it as is, using the
old ListGraph representation for native code.

59 files changed:
compiler/cmm/Cmm.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmCvt.hs [deleted file]
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmNode.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/OldCmm.hs [deleted file]
compiler/cmm/OldCmmLint.hs [deleted file]
compiler/cmm/OldCmmUtils.hs [deleted file]
compiler/cmm/OldPprCmm.hs [deleted file]
compiler/cmm/PprC.hs
compiler/cmm/PprCmmExpr.hs
compiler/codeGen/CgUtils.hs
compiler/ghc.cabal.in
compiler/llvmGen/LlvmCodeGen.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/llvmGen/LlvmCodeGen/Data.hs
compiler/llvmGen/LlvmCodeGen/Ppr.hs
compiler/main/CodeOutput.lhs
compiler/main/HscMain.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/Instruction.hs
compiler/nativeGen/PIC.hs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/PPC/Instr.hs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/PPC/RegInfo.hs
compiler/nativeGen/PPC/Regs.hs
compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
compiler/nativeGen/RegAlloc/Graph/Stats.hs
compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Linear/Stats.hs
compiler/nativeGen/RegAlloc/Liveness.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/SPARC/CodeGen/Amode.hs
compiler/nativeGen/SPARC/CodeGen/Base.hs
compiler/nativeGen/SPARC/CodeGen/CondCode.hs
compiler/nativeGen/SPARC/CodeGen/Expand.hs
compiler/nativeGen/SPARC/CodeGen/Gen32.hs
compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot
compiler/nativeGen/SPARC/CodeGen/Gen64.hs
compiler/nativeGen/SPARC/CodeGen/Sanity.hs
compiler/nativeGen/SPARC/Imm.hs
compiler/nativeGen/SPARC/Instr.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/SPARC/ShortcutJump.hs
compiler/nativeGen/Size.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/nativeGen/X86/Regs.hs
compiler/types/TyCon.lhs

index e1701bd..0b3040d 100644 (file)
@@ -8,8 +8,13 @@ module Cmm (
      CmmDecl, GenCmmDecl(..),
      CmmGraph, GenCmmGraph(..),
      CmmBlock,
+     RawCmmDecl, RawCmmGroup,
      Section(..), CmmStatics(..), CmmStatic(..),
 
+     -- ** Blocks containing lists
+     GenBasicBlock(..), blockId,
+     ListGraph(..), pprBBlock,
+
      -- * Cmm graphs
      CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
    
@@ -31,6 +36,7 @@ import SMRep
 import CmmExpr
 import UniqSupply
 import Compiler.Hoopl
+import Outputable
 
 import Data.Word        ( Word8 )
 
@@ -50,6 +56,7 @@ type CmmProgram = [CmmGroup]
 
 type GenCmmGroup d h g = [GenCmmDecl d h g]
 type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
+type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph
 
 -----------------------------------------------------------------------------
 --  CmmDecl, GenCmmDecl
@@ -62,7 +69,6 @@ type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
 --
 -- We expect there to be two main instances of this type:
 --   (a) C--, i.e. populated with various C-- constructs
---       (Cmm and RawCmm in OldCmm.hs)
 --   (b) Native code, populated with data/instructions
 
 -- | A top-level chunk, abstracted over the type of the contents of
@@ -87,6 +93,12 @@ data GenCmmDecl d h g
 
 type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
 
+type RawCmmDecl
+   = GenCmmDecl
+        CmmStatics
+        (BlockEnv CmmStatics)
+        CmmGraph
+
 -----------------------------------------------------------------------------
 --     Graphs
 -----------------------------------------------------------------------------
@@ -177,3 +189,28 @@ data CmmStatics
        CLabel      -- Label of statics
        [CmmStatic] -- The static data itself
 
+-- -----------------------------------------------------------------------------
+-- Basic blocks consisting of lists
+
+-- These are used by the LLVM and NCG backends, when populating Cmm
+-- with lists of instructions.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+
+-- | The branch block id is that of the first block in
+-- the branch, which is that branch's entry point
+blockId :: GenBasicBlock i -> BlockId
+blockId (BasicBlock blk_id _ ) = blk_id
+
+newtype ListGraph i = ListGraph [GenBasicBlock i]
+
+instance Outputable instr => Outputable (ListGraph instr) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance Outputable instr => Outputable (GenBasicBlock instr) where
+    ppr = pprBBlock
+
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
index 82f7243..c59a434 100644 (file)
@@ -4,17 +4,18 @@
 module CmmContFlowOpt
     ( cmmCfgOpts
     , cmmCfgOptsProc
+    , removeUnreachableBlocksProc
     , removeUnreachableBlocks
     , replaceLabels
     )
 where
 
+import Hoopl
 import BlockId
 import Cmm
 import CmmUtils
 import Maybes
 
-import Hoopl
 import Control.Monad
 import Prelude hiding (succ, unzip, zip)
 
@@ -136,9 +137,10 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
         = (blocks, mapInsert b' dest shortcut_map)
            -- replaceLabels will substitute dest for b' everywhere, later
 
-        -- non-calls: see if we can shortcut any of the successors.
+        -- non-calls: see if we can shortcut any of the successors,
+        -- and check whether we should invert the conditional
         | Nothing <- callContinuation_maybe last
-        = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
+        = ( mapInsert bid (blockJoinTail head swapcond_last) blocks
           , shortcut_map )
 
         | otherwise
@@ -146,17 +148,38 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
         where
           (head, last) = blockSplitTail block
           bid = entryLabel block
+
           shortcut_last = mapSuccessors shortcut last
-          shortcut l =
-             case mapLookup l blocks of
-               Just b | Just dest <- canShortcut b  -> dest
-               _otherwise -> l
+            where
+              shortcut l =
+                 case mapLookup l blocks of
+                   Just b | Just dest <- canShortcut b  -> dest
+                   _otherwise -> l
+
+          -- for a conditional, we invert the conditional if that
+          -- would make it more likely that the branch-not-taken case
+          -- becomes a fallthrough.  This helps the native codegen a
+          -- little bit, and probably has no effect on LLVM.  It's
+          -- convenient to do it here, where we have the information
+          -- about predecessors.
+          --
+          swapcond_last
+            | CmmCondBranch cond t f <- shortcut_last
+            , numPreds f > 1
+            , numPreds t == 1
+            , Just cond' <- maybeInvertCmmExpr cond
+            = CmmCondBranch cond' f t
+
+            | otherwise
+            = shortcut_last
+
 
      shouldConcatWith b block
        | okToDuplicate block = True  -- short enough to duplicate
-       | num_preds b == 1    = True  -- only one predecessor: go for it
+       | numPreds b == 1     = True  -- only one predecessor: go for it
        | otherwise           = False
-       where num_preds bid = mapLookup bid backEdges `orElse` 0
+
+     numPreds bid = mapLookup bid backEdges `orElse` 0
 
      canShortcut :: CmmBlock -> Maybe BlockId
      canShortcut block
@@ -265,6 +288,10 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
 --
 -- Removing unreachable blocks
 
+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
+removeUnreachableBlocksProc (CmmProc info lbl live g)
+   = CmmProc info lbl live (removeUnreachableBlocks g)
+
 removeUnreachableBlocks :: CmmGraph -> CmmGraph
 removeUnreachableBlocks g
   | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
deleted file mode 100644 (file)
index 39f0b86..0000000
+++ /dev/null
@@ -1,117 +0,0 @@
-{-# LANGUAGE GADTs #-}
--- ToDo: remove -fno-warn-incomplete-patterns
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-
-module CmmCvt
-  ( cmmOfZgraph )
-where
-
-import BlockId
-import Cmm
-import CmmUtils
-import qualified OldCmm as Old
-import OldPprCmm ()
-
-import Hoopl
-import Data.Maybe
-import Maybes
-import Outputable
-
-cmmOfZgraph :: CmmGroup -> Old.CmmGroup
-cmmOfZgraph tops = map mapTop tops
-  where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g)
-        mapTop (CmmData s ds) = CmmData s ds
-
-add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
-add_hints args hints = zipWith Old.CmmHinted args hints
-
-get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
-get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
-                             arg_hints ++ repeat NoHint)
-  where (res_hints, arg_hints) = callishMachOpHints op
-get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
-  = (res_hints, arg_hints)
-
-cmm_target :: ForeignTarget -> Old.CmmCallTarget
-cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
-cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
-
-get_ret :: ForeignTarget -> CmmReturnInfo
-get_ret (PrimTarget _) = CmmMayReturn
-get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
-
-ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
-ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
-  -- We catenated some blocks in the conversion process,
-  -- because of the CmmCondBranch -- the machine code does not have
-  -- 'jump here or there' instruction, but has 'jump if true' instruction.
-  -- As OldCmm has the same instruction, so we use it.
-  -- When we are doing this, we also catenate normal goto-s (it is for free).
-
-  -- Exactly, we catenate blocks with nonentry labes, that are
-  --   a) mentioned exactly once as a successor
-  --   b) any of 1) are a target of a goto
-  --             2) are false branch target of a conditional jump
-  --             3) are true branch target of a conditional jump, and
-  --                  the false branch target is a successor of at least 2 blocks
-  --                  and the condition can be inverted
-  -- The complicated rule 3) is here because we need to assign at most one
-  -- catenable block to a CmmCondBranch.
-    where preds :: BlockEnv [CmmNode O C]
-          preds = mapFold add mapEmpty $ toBlockMap g
-            where add block env = foldr (add' $ lastNode block) env (successors block)
-                  add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
-                  add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
-
-          to_be_catenated :: BlockId -> Bool
-          to_be_catenated id | id == g_entry g = False
-                             | Just [CmmBranch _] <- mapLookup id preds = True
-                             | Just [CmmCondBranch _ _ f] <- mapLookup id preds
-                             , f == id = True
-                             | Just [CmmCondBranch e t f] <- mapLookup id preds
-                             , t == id
-                             , Just (_:_:_) <- mapLookup f preds
-                             , Just _ <- maybeInvertCmmExpr e = True
-          to_be_catenated _ = False
-
-          convert_block block | to_be_catenated (entryLabel block) = Nothing
-          convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
-            where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
-                  first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
-
-                  middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
-                  middle node stmts = stmt : stmts
-                    where stmt :: Old.CmmStmt
-                          stmt = case node of
-                            CmmComment s                                   -> Old.CmmComment s
-                            CmmAssign l r                                  -> Old.CmmAssign l r
-                            CmmStore  l r                                  -> Old.CmmStore  l r
-                            CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
-                            CmmUnsafeForeignCall target ress args          ->
-                              Old.CmmCall (cmm_target target)
-                                          (add_hints ress res_hints)
-                                          (add_hints args arg_hints)
-                                          (get_ret target)
-                                  where
-                                     (res_hints, arg_hints) = get_hints target
-
-
-                  last :: CmmNode O C -> () -> [Old.CmmStmt]
-                  last node _ = stmts
-                    where stmts :: [Old.CmmStmt]
-                          stmts = case node of
-                            CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
-                                          | otherwise -> [Old.CmmBranch tgt]
-                            CmmCondBranch expr tid fid
-                              | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
-                              | to_be_catenated tid
-                              , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
-                              | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
-                            CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
-                            -- ToDo: STG Live
-                            CmmCall e _ r _ _ _ -> [Old.CmmJump e r]
-                            CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
-                          tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
-                                          Old.BasicBlock _ stmts -> stmts
-                            where Just block = mapLookup bid $ toBlockMap g
-
index 699469c..b4e2cd6 100644 (file)
@@ -14,8 +14,7 @@ module CmmInfo (
 
 #include "HsVersions.h"
 
-import OldCmm as Old
-
+import Cmm
 import CmmUtils
 import CLabel
 import SMRep
@@ -42,8 +41,8 @@ mkEmptyContInfoTable info_lbl
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
-cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
-            -> IO (Stream IO Old.RawCmmGroup ())
+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
+            -> IO (Stream IO RawCmmGroup ())
 cmmToRawCmm dflags cmms
   = do { uniqs <- mkSplitUniqSupply 'i'
        ; let do_one uniqs cmm = do
@@ -108,21 +107,13 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
           rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
           rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
         --
-        case blocks of
-          ListGraph [] ->
-              -- No code; only the info table is significant
-              -- Use a zero place-holder in place of the
-              -- entry-label in the info table
-              return (top_decls ++
-                      [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
-                                                                rel_extra_bits)])
-          _nonempty ->
-             -- Separately emit info table (with the function entry
-             -- point as first entry) and the entry code
-             return (top_decls ++
-                     [CmmProc mapEmpty entry_lbl live blocks,
-                      mkDataLits Data info_lbl
-                         (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+        -- Separately emit info table (with the function entry
+        -- point as first entry) and the entry code
+        --
+        return (top_decls ++
+                [CmmProc mapEmpty entry_lbl live blocks,
+                 mkDataLits Data info_lbl
+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
 
   --
   -- With tables-next-to-code, we can have many info tables,
@@ -132,7 +123,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
   --
   | otherwise
   = do
-    (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
+    (top_declss, raw_infos) <-
+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
     return (concat top_declss ++
             [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
 
index 6fa3007..d808c7f 100644 (file)
@@ -12,7 +12,8 @@
 
 module CmmNode (
      CmmNode(..), CmmFormal, CmmActual,
-     UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..),
+     UpdFrameOffset, Convention(..),
+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
      CmmReturnInfo(..),
      mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
      mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
@@ -281,6 +282,17 @@ data ForeignTarget        -- The target of a foreign call
         CallishMachOp            -- Which one
   deriving Eq
 
+foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+foreignTargetHints target
+  = ( res_hints ++ repeat NoHint
+    , arg_hints ++ repeat NoHint )
+  where
+    (res_hints, arg_hints) =
+       case target of
+          PrimTarget op -> callishMachOpHints op
+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
+             (res_hints, arg_hints)
+
 --------------------------------------------------
 -- Instances of register and slot users / definers
 
index 0d44f0f..f89c081 100644 (file)
@@ -8,14 +8,13 @@
 
 module CmmOpt (
         cmmMachOpFold,
-        cmmMachOpFoldM,
-        cmmLoopifyForC,
+        cmmMachOpFoldM
  ) where
 
 #include "HsVersions.h"
 
 import CmmUtils
-import OldCmm
+import Cmm
 import DynFlags
 import CLabel
 
@@ -416,6 +415,7 @@ exactLog2 x_
   except factorial, but what the hell.
 -}
 
+{-
 cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl
 -- XXX: revisit if we actually want to do this
 -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p  -- only if there's an info table, ignore case alts
@@ -434,6 +434,7 @@ cmmLoopifyForC dflags (CmmProc infos entry_lbl live
                  | otherwise               = entry_lbl
 
 cmmLoopifyForC _ top = top
+-}
 
 -- -----------------------------------------------------------------------------
 -- Utils
index 70ff754..4e9a90a 100644 (file)
@@ -134,6 +134,8 @@ cpsTop hsc_env proc =
                   return $ if optLevel dflags >= 1
                              then map (cmmCfgOptsProc splitting_proc_points) gs
                              else gs
+            gs <- return (map removeUnreachableBlocksProc gs)
+                -- Note [unreachable blocks]
             dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
 
             return (cafEnv, gs)
@@ -152,6 +154,8 @@ cpsTop hsc_env proc =
                  return $ if optLevel dflags >= 1
                              then cmmCfgOptsProc splitting_proc_points g
                              else g
+            g <- return (removeUnreachableBlocksProc g)
+                -- Note [unreachable blocks]
             dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
 
             return (cafEnv, [g])
@@ -212,7 +216,15 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
 
 -}
 
+{- Note [unreachable blocks]
 
+The control-flow optimiser sometimes leaves unreachable blocks behind
+containing junk code.  If these blocks make it into the native code
+generator then they trigger a register allocator panic because they
+refer to undefined LocalRegs, so we must eliminate any unreachable
+blocks before passing the code onwards.
+
+-}
 
 runUniqSM :: UniqSM a -> IO a
 runUniqSM m = do
index d52c6a3..c822da9 100644 (file)
@@ -51,9 +51,8 @@ module CmmUtils(
         -- * Operations that probably don't belong here
         modifyGraph,
 
-        lastNode, replaceLastNode,
         ofBlockMap, toBlockMap, insertBlock,
-        ofBlockList, toBlockList, bodyToBlockList,
+        ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst,
         foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
 
         analFwd, analBwd, analRewFwd, analRewBwd,
@@ -424,6 +423,17 @@ insertBlock block map =
 toBlockList :: CmmGraph -> [CmmBlock]
 toBlockList g = mapElems $ toBlockMap g
 
+-- | like 'toBlockList', but the entry block always comes first
+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirst g
+  | mapNull m  = []
+  | otherwise  = entry_block : others
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+    others = filter ((/= entry_id) . entryLabel) (mapElems m)
+
 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
 ofBlockList entry blocks = CmmGraph { g_entry = entry
                                     , g_graph = GMany NothingO body NothingO }
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
deleted file mode 100644 (file)
index fccdd81..0000000
+++ /dev/null
@@ -1,279 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-
------------------------------------------------------------------------------
---
--- Old-style Cmm data types
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module OldCmm (
-        CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl,
-        ListGraph(..),
-        CmmInfoTable(..), ClosureTypeInfo(..), topInfoTable,
-        CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
-
-        cmmMapGraph, cmmTopMapGraph,
-
-        GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
-
-        CmmStmt(..), New.CmmReturnInfo(..), CmmHinted(..),
-        HintedCmmFormal, HintedCmmActual,
-
-        CmmSafety(..), CmmCallTarget(..),
-        New.GenCmmDecl(..), New.ForeignHint(..),
-
-        module CmmExpr,
-
-        Section(..), ProfilingInfo(..), New.C_SRT(..)
-    ) where
-
-#include "HsVersions.h"
-
-import qualified Cmm as New
-import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..),
-             CmmFormal, CmmActual, Section(..), CmmStatic(..),
-             ProfilingInfo(..), ClosureTypeInfo(..) )
-
-import BlockId
-import CmmExpr
-import FastString
-import ForeignCall
-
-
--- A [[BlockId]] is a local label.
--- Local labels must be unique within an entire compilation unit, not
--- just a single top-level item, because local labels map one-to-one
--- with assembly-language labels.
-
------------------------------------------------------------------------------
---  Cmm, CmmDecl, CmmBasicBlock
------------------------------------------------------------------------------
-
--- A file is a list of top-level chunks.  These may be arbitrarily
--- re-orderd during code generation.
-
--- | A control-flow graph represented as a list of extended basic blocks.
---
--- 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.
---
--- BlockIds must be unique across an entire compilation unit, since
--- they are translated to assembly-language labels, which scope
--- across a whole compilation unit.
-newtype ListGraph i = ListGraph [GenBasicBlock i]
-
-type CmmInfoTables = BlockEnv CmmInfoTable
-
--- | Cmm with the info table as a data type
-type CmmGroup = GenCmmGroup CmmStatics CmmInfoTables (ListGraph CmmStmt)
-type CmmDecl = GenCmmDecl CmmStatics CmmInfoTables (ListGraph CmmStmt)
-
--- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info
--- table label. If we are building without tables-next-to-code there will be no statics
---
--- INVARIANT: if there is an info table, it has at least one CmmStatic
-type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt)
-type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph 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.
--- Fall-through is not allowed: there must be an explicit jump at the
--- end of each basic block, but the code generator might rearrange basic
--- blocks in order to turn some jumps into fallthroughs.
-
-data GenBasicBlock i = BasicBlock BlockId [i]
-type CmmBasicBlock   = GenBasicBlock CmmStmt
-
-instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where
-    foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l
-
--- | The branch block id is that of the first block in
--- the branch, which is that branch's entry point
-blockId :: GenBasicBlock i -> BlockId
-blockId (BasicBlock blk_id _ ) = blk_id
-
-blockStmts :: GenBasicBlock i -> [i]
-blockStmts (BasicBlock _ stmts) = stmts
-
-mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i'
-mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-
--- | Returns the info table associated with the CmmDecl's entry point,
--- if any.
-topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
-topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
-  = mapLookup (blockId b) infos
-topInfoTable _
-  = Nothing
-
-----------------------------------------------------------------
---   graph maps
-----------------------------------------------------------------
-
-cmmMapGraph    :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g'
-cmmMapGraph f tops = map (cmmTopMapGraph f) tops
-
-cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g'
-cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g)
-cmmTopMapGraph _ (CmmData s ds)    = CmmData s ds
-
------------------------------------------------------------------------------
---              CmmStmt
--- A "statement".  Note that all branches are explicit: there are no
--- control transfers to computed addresses, except when transfering
--- control to a new function.
------------------------------------------------------------------------------
-
-data CmmStmt
-  = CmmNop
-  | CmmComment FastString
-
-  | CmmAssign CmmReg CmmExpr      -- Assign to register
-
-  | CmmStore CmmExpr CmmExpr      -- Assign to memory location. Size is
-                                  -- given by cmmExprType of the rhs.
-
-  | CmmCall                       -- A call (foreign, native or primitive), with
-      CmmCallTarget
-      [HintedCmmFormal]            -- zero or more results
-      [HintedCmmActual]            -- zero or more arguments
-      New.CmmReturnInfo
-      -- Some care is necessary when handling the arguments of these, see
-      -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
-
-  | CmmBranch BlockId             -- branch to another BB in this fn
-
-  | CmmCondBranch CmmExpr BlockId -- conditional branch
-
-  | CmmSwitch                     -- Table branch
-      CmmExpr                       -- The scrutinee is zero-based;
-      [Maybe BlockId]               --      zero -> first block
-                                    --      one  -> second block etc
-                                    -- Undefined outside range, and when
-                                    -- there's a Nothing
-
-  | CmmJump                       -- Jump to another C-- function,
-      CmmExpr                       -- Target
-      [GlobalReg]                   -- Live registers at call site;
-                                    --      Nothing -> no information, assume
-                                    --                 all live
-                                    --      Just .. -> info on liveness, []
-                                    --                 means no live registers
-                                    -- This isn't all 'live' registers, just
-                                    -- the argument STG registers that are live
-                                    -- AND also possibly mapped to machine
-                                    -- registers. (So Sp, Hp, HpLim... ect
-                                    -- are never included here as they are
-                                    -- always live, only R2.., D1.. are
-                                    -- on this list)
-
-  | CmmReturn                     -- Return from a native C-- function,
-
-data CmmHinted a
-  = CmmHinted {
-        hintlessCmm :: a,
-        cmmHint :: New.ForeignHint
-    }
-  deriving( Eq )
-
-type HintedCmmFormal = CmmHinted CmmFormal
-type HintedCmmActual = CmmHinted CmmActual
-
-data CmmSafety
-  = CmmUnsafe
-  | CmmSafe New.C_SRT
-  | CmmInterruptible
-
--- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]'
-instance UserOfRegs LocalReg CmmStmt where
-  foldRegsUsed dflags f (set::b) s = stmt s set
-    where
-      stmt :: CmmStmt -> b -> b
-      stmt (CmmNop)                  = id
-      stmt (CmmComment {})           = id
-      stmt (CmmAssign _ e)           = gen e
-      stmt (CmmStore e1 e2)          = gen e1 . gen e2
-      stmt (CmmCall target _ es _)   = gen target . gen es
-      stmt (CmmBranch _)             = id
-      stmt (CmmCondBranch e _)       = gen e
-      stmt (CmmSwitch e _)           = gen e
-      stmt (CmmJump e _)             = gen e
-      stmt (CmmReturn)               = id
-
-      gen :: UserOfRegs LocalReg a => a -> b -> b
-      gen a set = foldRegsUsed dflags f set a
-
-instance UserOfRegs LocalReg CmmCallTarget where
-    foldRegsUsed dflags f set (CmmCallee e _)    = foldRegsUsed dflags f set e
-    foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts
-
-instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where
-    foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a)
-
-instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where
-    foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a)
-
-{-
-Discussion
-~~~~~~~~~~
-
-One possible problem with the above type is that the only way to do a
-non-local conditional jump is to encode it as a branch to a block that
-contains a single jump.  This leads to inefficient code in the back end.
-
-[N.B. This problem will go away when we make the transition to the
-'zipper' form of control-flow graph, in which both targets of a
-conditional jump are explicit. ---NR]
-
-One possible way to fix this would be:
-
-data CmmStat =
-  ...
-  | CmmJump CmmBranchDest
-  | CmmCondJump CmmExpr CmmBranchDest
-  ...
-
-data CmmBranchDest
-  = Local BlockId
-  | NonLocal CmmExpr [LocalReg]
-
-In favour:
-
-+ one fewer constructors in CmmStmt
-+ allows both cond branch and switch to jump to non-local destinations
-
-Against:
-
-- not strictly necessary: can already encode as branch+jump
-- not always possible to implement any better in the back end
-- could do the optimisation in the back end (but then plat-specific?)
-- C-- doesn't have it
-- back-end optimisation might be more general (jump shortcutting)
-
-So we'll stick with the way it is, and add the optimisation to the NCG.
--}
-
------------------------------------------------------------------------------
---              CmmCallTarget
---
--- The target of a CmmCall.
------------------------------------------------------------------------------
-
-data CmmCallTarget
-  = CmmCallee           -- Call a function (foreign or native)
-        CmmExpr                 -- literal label <=> static call
-                                -- other expression <=> dynamic call
-        CCallConv               -- The calling convention
-
-  | CmmPrim             -- Call a "primitive" (eg. sin, cos)
-        CallishMachOp           -- These might be implemented as inline
-                                -- code by the backend.
-        -- If we don't know how to implement the
-        -- mach op, then we can replace it with
-        -- this list of statements:
-        (Maybe [CmmStmt])
-
diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs
deleted file mode 100644 (file)
index 9a4fb42..0000000
+++ /dev/null
@@ -1,212 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2004-2006
---
--- CmmLint: checking the correctness of Cmm statements and expressions
---
------------------------------------------------------------------------------
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module OldCmmLint (
-  cmmLint, cmmLintTop
-  ) where
-
-import BlockId
-import OldCmm
-import Outputable
-import OldPprCmm()
-import FastString
-import DynFlags
-
-import Data.Maybe
-
--- -----------------------------------------------------------------------------
--- Exported entry points:
-
-cmmLint :: (Outputable d, Outputable h)
-        => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
-
-cmmLintTop :: (Outputable d, Outputable h)
-           => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top
-
-runCmmLint :: Outputable a
-           => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint _ l p =
-   case unCL (l p) of
-   Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
-                           nest 2 err,
-                           ptext $ sLit ("Program was:"),
-                           nest 2 (ppr p)])
-   Right _  -> Nothing
-
-lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks))
-  = addLintInfo (text "in proc " <> ppr lbl) $
-        let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
-        in  mapM_ (lintCmmBlock dflags labels) blocks
-
-lintCmmDecl _ (CmmData {})
-  = return ()
-
-lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
-lintCmmBlock dflags labels (BasicBlock id stmts)
-  = addLintInfo (text "in basic block " <> ppr id) $
-       mapM_ (lintCmmStmt dflags labels) stmts
-
--- -----------------------------------------------------------------------------
--- lintCmmExpr
-
--- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
--- byte/word mismatches.
-
-lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType
-lintCmmExpr dflags (CmmLoad expr rep) = do
-  _ <- lintCmmExpr dflags expr
-  -- Disabled, if we have the inlining phase before the lint phase,
-  -- we can have funny offsets due to pointer tagging. -- EZY
-  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-  --   cmmCheckWordAddress expr
-  return rep
-lintCmmExpr dflags expr@(CmmMachOp op args) = do
-  tys <- mapM (lintCmmExpr dflags) args
-  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
-       then cmmCheckMachOp dflags op args tys
-       else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
-lintCmmExpr dflags (CmmRegOff reg offset)
-  = lintCmmExpr dflags (CmmMachOp (MO_Add rep)
-               [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
-  where rep = typeWidth (cmmRegType dflags reg)
-lintCmmExpr dflags expr =
-  return (cmmExprType dflags expr)
-
--- Check for some common byte/word mismatches (eg. Sp + 1)
-cmmCheckMachOp   :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
-  = cmmCheckMachOp dflags op [reg, lit] tys
-cmmCheckMachOp dflags op _ tys
-  = return (machOpResultType dflags op tys)
-
-{-
-isOffsetOp :: MachOp -> Bool
-isOffsetOp (MO_Add _) = True
-isOffsetOp (MO_Sub _) = True
-isOffsetOp _ = False
-
--- This expression should be an address from which a word can be loaded:
--- check for funny-looking sub-word offsets.
-_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
-_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
-  = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
-  = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress _
-  = return ()
-
--- No warnings for unaligned arithmetic with the node register,
--- which is used to extract fields from tagged constructor closures.
-notNodeReg :: CmmExpr -> Bool
-notNodeReg (CmmReg reg) | reg == nodeReg = False
-notNodeReg _                             = True
--}
-
-lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint ()
-lintCmmStmt dflags labels = lint
-    where lint (CmmNop) = return ()
-          lint (CmmComment {}) = return ()
-          lint stmt@(CmmAssign reg expr) = do
-            erep <- lintCmmExpr dflags expr
-            let reg_ty = cmmRegType dflags reg
-            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
-                then return ()
-                else cmmLintAssignErr stmt erep reg_ty
-          lint (CmmStore l r) = do
-            _ <- lintCmmExpr dflags l
-            _ <- lintCmmExpr dflags r
-            return ()
-          lint (CmmCall target _res args _) =
-              do lintTarget dflags labels target
-                 mapM_ (lintCmmExpr dflags . hintlessCmm) args
-          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e
-          lint (CmmSwitch e branches) = do
-            mapM_ checkTarget $ catMaybes branches
-            erep <- lintCmmExpr dflags e
-            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
-              then return ()
-              else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
-                               text " :: " <> ppr erep)
-          lint (CmmJump e _) = lintCmmExpr dflags e >> return ()
-          lint (CmmReturn) = return ()
-          lint (CmmBranch id)    = checkTarget id
-          checkTarget id = if setMember id labels then return ()
-                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-
-lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint ()
-lintTarget dflags _      (CmmCallee e _) = do _ <- lintCmmExpr dflags e
-                                              return ()
-lintTarget _      _      (CmmPrim _ Nothing) = return ()
-lintTarget dflags labels (CmmPrim _ (Just stmts))
-    = mapM_ (lintCmmStmt dflags labels) stmts
-
-
-checkCond :: DynFlags -> CmmExpr -> CmmLint ()
-checkCond _      (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
-checkCond _      expr
-    = cmmLintErr (hang (text "expression is not a conditional:") 2
-                       (ppr expr))
-
--- -----------------------------------------------------------------------------
--- CmmLint monad
-
--- just a basic error monad:
-
-newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
-
-instance Monad CmmLint where
-  CmmLint m >>= k = CmmLint $ case m of 
-                               Left e -> Left e
-                               Right a -> unCL (k a)
-  return a = CmmLint (Right a)
-
-cmmLintErr :: SDoc -> CmmLint a
-cmmLintErr msg = CmmLint (Left msg)
-
-addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $ 
-   case unCL thing of
-       Left err -> Left (hang info 2 err)
-       Right a  -> Right a
-
-cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
-cmmLintMachOpErr expr argsRep opExpectsRep
-     = cmmLintErr (text "in MachOp application: " $$ 
-                                       nest 2 (ppr expr) $$
-                                       (text "op is expecting: " <+> ppr opExpectsRep) $$
-                                       (text "arguments provide: " <+> ppr argsRep))
-
-cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
-cmmLintAssignErr stmt e_ty r_ty
-  = cmmLintErr (text "in assignment: " $$ 
-               nest 2 (vcat [ppr stmt, 
-                             text "Reg ty:" <+> ppr r_ty,
-                             text "Rhs ty:" <+> ppr e_ty]))
-                        
-                                       
-
-{-
-cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
-cmmLintDubiousWordOffset expr
-   = cmmLintErr (text "offset is not a multiple of words: " $$
-                       nest 2 (ppr expr))
--}
-
diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs
deleted file mode 100644 (file)
index fe6ccee..0000000
+++ /dev/null
@@ -1,100 +0,0 @@
------------------------------------------------------------------------------
---
--- Old-style Cmm utilities.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module OldCmmUtils(
-        CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
-        isNopStmt,
-
-        maybeAssignTemp, loadArgsIntoTemps,
-
-        module CmmUtils,
-  ) where
-
-#include "HsVersions.h"
-
-import OldCmm
-import CmmUtils
-import OrdList
-import DynFlags
-import Unique
-
----------------------------------------------------
---
---      CmmStmts
---
----------------------------------------------------
-
-type CmmStmts = OrdList CmmStmt
-
-noStmts :: CmmStmts
-noStmts = nilOL
-
-oneStmt :: CmmStmt -> CmmStmts
-oneStmt = unitOL
-
-mkStmts :: [CmmStmt] -> CmmStmts
-mkStmts = toOL
-
-plusStmts :: CmmStmts -> CmmStmts -> CmmStmts
-plusStmts = appOL
-
-stmtList :: CmmStmts -> [CmmStmt]
-stmtList = fromOL
-
-
----------------------------------------------------
---
---      CmmStmt
---
----------------------------------------------------
-
-isNopStmt :: CmmStmt -> Bool
--- If isNopStmt returns True, the stmt is definitely a no-op;
--- but it might be a no-op even if isNopStmt returns False
-isNopStmt CmmNop                       = True
-isNopStmt (CmmAssign r e)              = cheapEqReg r e
-isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2
-isNopStmt _                            = False
-
-cheapEqExpr :: CmmExpr -> CmmExpr -> Bool
-cheapEqExpr (CmmReg r)      e                 = cheapEqReg r e
-cheapEqExpr (CmmRegOff r 0) e                 = cheapEqReg r e
-cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n'
-cheapEqExpr _               _                 = False
-
-cheapEqReg :: CmmReg -> CmmExpr -> Bool
-cheapEqReg r (CmmReg r')      = r==r'
-cheapEqReg r (CmmRegOff r' 0) = r==r'
-cheapEqReg _ _                = False
-
----------------------------------------------------
---
---      Helpers for foreign call arguments
---
----------------------------------------------------
-
-loadArgsIntoTemps :: DynFlags -> [Unique]
-                  -> [HintedCmmActual]
-                  -> ([Unique], [CmmStmt], [HintedCmmActual])
-loadArgsIntoTemps _      uniques [] = (uniques, [], [])
-loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) =
-    (uniques'',
-     new_stmts ++ remaining_stmts,
-     (CmmHinted new_e hint) : remaining_e)
-    where
-      (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e
-      (uniques'', remaining_stmts, remaining_e) =
-          loadArgsIntoTemps dflags uniques' args
-
-
-maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr)
-maybeAssignTemp dflags uniques e
-    | hasNoGlobalRegs e = (uniques, [], e)
-    | otherwise         = (tail uniques, [CmmAssign local e], CmmReg local)
-    where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e))
-
diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
deleted file mode 100644 (file)
index edfaef8..0000000
+++ /dev/null
@@ -1,224 +0,0 @@
-----------------------------------------------------------------------------
---
--- Pretty-printing of old-style Cmm as (a superset of) C--
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
---
--- This is where we walk over Cmm emitting an external representation,
--- suitable for parsing, in a syntax strongly reminiscent of C--. This
--- is the "External Core" for the Cmm layer.
---
--- As such, this should be a well-defined syntax: we want it to look nice.
--- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
--- slightly, in some cases. For one, we use I8 .. I64 for types, rather
--- than C--'s bits8 .. bits64.
---
--- We try to ensure that all information available in the abstract
--- syntax is reproduced, or reproducible, in the concrete syntax.
--- Data that is not in printed out can be reconstructed according to
--- conventions used in the pretty printer. There are at least two such
--- cases:
---      1) if a value has wordRep type, the type is not appended in the
---      output.
---      2) MachOps that operate over wordRep type are printed in a
---      C-style, rather than as their internal MachRep name.
---
--- These conventions produce much more readable Cmm output.
---
--- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
---
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module OldPprCmm (
-        pprStmt,
-        module PprCmmDecl,
-        module PprCmmExpr
-    ) where
-
-import BlockId
-import CLabel
-import CmmUtils
-import OldCmm
-import PprCmmDecl
-import PprCmmExpr
-
-import BasicTypes
-import ForeignCall
-import Outputable
-import FastString
-
-import Data.List
-
------------------------------------------------------------------------------
-
-instance Outputable instr => Outputable (ListGraph instr) where
-    ppr (ListGraph blocks) = vcat (map ppr blocks)
-
-instance Outputable instr => Outputable (GenBasicBlock instr) where
-    ppr = pprBBlock
-
-instance Outputable CmmStmt where
-    ppr s = pprStmt s
-
--- --------------------------------------------------------------------------
-instance Outputable CmmSafety where
-  ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
-  ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
-  ppr (CmmSafe srt) = ppr srt
-
--- --------------------------------------------------------------------------
--- Basic blocks look like assembly blocks.
---      lbl: stmt ; stmt ; ..
-pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
-pprBBlock (BasicBlock ident stmts) =
-    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-
--- --------------------------------------------------------------------------
--- Statements. C-- usually, exceptions to this should be obvious.
---
-pprStmt :: CmmStmt -> SDoc
-pprStmt stmt = case stmt of
-
-    -- ;
-    CmmNop -> semi
-
-    -- // text
-    CmmComment s -> text "//" <+> ftext s
-
-    -- reg = expr;
-    CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-
-    -- rep[lv] = expr;
-    CmmStore lv expr ->
-        sdocWithDynFlags $ \dflags ->
-        let rep = ppr ( cmmExprType dflags expr )
-        in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
-
-    -- call "ccall" foo(x, y)[r1, r2];
-    -- ToDo ppr volatile
-    CmmCall (CmmCallee fn cconv) results args ret ->
-        sep  [ pp_lhs <+> pp_conv
-             , nest 2 (pprExpr9 fn <>
-                       parens (commafy (map ppr_ar args)))
-             , case ret of CmmMayReturn -> empty
-                           CmmNeverReturns -> ptext $ sLit (" never returns")
-             ] <> semi
-        where
-          pp_lhs | null results = empty
-                 | otherwise    = commafy (map ppr_ar results) <+> equals
-                -- Don't print the hints on a native C-- call
-          ppr_ar (CmmHinted ar k) = ppr (ar,k)
-          pp_conv = ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
-
-    -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
-    CmmCall (CmmPrim op _) results args ret ->
-        pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret)
-        where
-          -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
-          --       use one to get the label printed.
-          lbl = CmmLabel (mkForeignLabel
-                                (mkFastString (show op))
-                                Nothing ForeignLabelInThisPackage IsFunction)
-
-    CmmBranch ident          -> genBranch ident
-    CmmCondBranch expr ident -> genCondBranch expr ident
-    CmmJump expr live        -> genJump expr live
-    CmmReturn                -> genReturn
-    CmmSwitch arg ids        -> genSwitch arg ids
-
--- Just look like a tuple, since it was a tuple before
--- ... is that a good idea? --Isaac Dupree
-instance (Outputable a) => Outputable (CmmHinted a) where
-  ppr (CmmHinted a k) = ppr (a, k)
-
--- --------------------------------------------------------------------------
--- goto local label. [1], section 6.6
---
---     goto lbl;
---
-genBranch :: BlockId -> SDoc
-genBranch ident =
-    ptext (sLit "goto") <+> ppr ident <> semi
-
--- --------------------------------------------------------------------------
--- Conditional. [1], section 6.4
---
---     if (expr) { goto lbl; }
---
-genCondBranch :: CmmExpr -> BlockId -> SDoc
-genCondBranch expr ident =
-    hsep [ ptext (sLit "if")
-         , parens (ppr expr)
-         , ptext (sLit "goto")
-         , ppr ident <> semi ]
-
--- --------------------------------------------------------------------------
--- A tail call. [1], Section 6.9
---
---     jump foo(a, b, c);
---
-genJump :: CmmExpr -> [GlobalReg] -> SDoc
-genJump expr live =
-    hcat [ ptext (sLit "jump")
-         , space
-         , if isTrivialCmmExpr expr
-                then pprExpr expr
-                else case expr of
-                    CmmLoad (CmmReg _) _ -> pprExpr expr
-                    _                    -> parens (pprExpr expr)
-         , semi <+> ptext (sLit "// ")
-         , ppr live]
-
--- --------------------------------------------------------------------------
--- Return from a function. [1], Section 6.8.2 of version 1.128
---
---     return (a, b, c);
---
-genReturn :: SDoc
-genReturn = hcat [ ptext (sLit "return") , semi ]
-
--- --------------------------------------------------------------------------
--- Tabled jump to local label
---
--- The syntax is from [1], section 6.5
---
---      switch [0 .. n] (expr) { case ... ; }
---
-genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
-genSwitch expr maybe_ids
-
-    = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
-
-      in hang (hcat [ ptext (sLit "switch [0 .. ")
-                    , int (length maybe_ids - 1)
-                    , ptext (sLit "] ")
-                    , if isTrivialCmmExpr expr
-                        then pprExpr expr
-                        else parens (pprExpr expr)
-                    , ptext (sLit " {")
-                    ])
-            4 (vcat ( map caseify pairs )) $$ rbrace
-
-    where
-      snds a b = (snd a) == (snd b)
-
-      caseify :: [(Int,Maybe BlockId)] -> SDoc
-      caseify ixs@((_,Nothing):_)
-        = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
-                <> ptext (sLit " */")
-      caseify as
-        = let (is,ids) = unzip as
-          in hsep [ ptext (sLit "case")
-                  , hcat (punctuate comma (map int is))
-                  , ptext (sLit ": goto")
-                  , ppr (head [ id | Just id <- ids]) <> semi ]
-
------------------------------------------------------------------------------
-
-commafy :: [SDoc] -> SDoc
-commafy xs = fsep $ punctuate comma xs
-
index e0ff99c..ee964d8 100644 (file)
@@ -16,6 +16,7 @@
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE GADTs #-}
 module PprC (
         writeCs,
         pprStringInCStyle
@@ -27,8 +28,10 @@ module PprC (
 import BlockId
 import CLabel
 import ForeignCall
-import OldCmm
-import OldPprCmm ()
+import Cmm hiding (pprBBlock)
+import PprCmm ()
+import Hoopl
+import CmmUtils
 
 -- Utils
 import CPrim
@@ -81,8 +84,9 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops
 -- top level procs
 --
 pprTop :: RawCmmDecl -> SDoc
-pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) =
-    (case topInfoTable proc of
+pprTop (CmmProc infos clbl _ graph) =
+
+    (case mapLookup (g_entry graph) infos of
        Nothing -> empty
        Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
                                             pprWordArray info_clbl info_dat) $$
@@ -93,16 +97,12 @@ pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) =
                     then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
            nest 8 temp_decls,
            nest 8 mkFB_,
-           case blocks of
-               [] -> empty
-               -- the first block doesn't get a label:
-               (BasicBlock _ stmts : rest) ->
-                    nest 8 (vcat (map pprStmt stmts)) $$
-                       vcat (map pprBBlock rest),
+           vcat (map pprBBlock blocks),
            nest 8 mkFE_,
            rbrace ]
     )
   where
+        blocks = toBlockList graph
         (temp_decls, extern_decls) = pprTempAndExternDecls blocks
 
 
@@ -133,14 +133,12 @@ pprTop (CmmData _section (Statics lbl lits)) =
 -- as many jumps as possible into fall throughs.
 --
 
-pprBBlock :: CmmBasicBlock -> SDoc
-pprBBlock (BasicBlock lbl stmts) =
-    if null stmts then
-        pprTrace "pprC.pprBBlock: curious empty code block for"
-                        (pprBlockId lbl) empty
-    else
-        nest 4 (pprBlockId lbl <> colon) $$
-        nest 8 (vcat (map pprStmt stmts))
+pprBBlock :: CmmBlock -> SDoc
+pprBBlock block =
+  nest 4 (pprBlockId lbl <> colon) $$
+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
+ where
+  (CmmEntry lbl, nodes, last)  = blockSplit block
 
 -- --------------------------------------------------------------------------
 -- Info tables. Just arrays of words.
@@ -165,13 +163,11 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
 -- Statements.
 --
 
-pprStmt :: CmmStmt -> SDoc
+pprStmt :: CmmNode e x -> SDoc
 
 pprStmt stmt =
     sdocWithDynFlags $ \dflags ->
     case stmt of
-    CmmReturn    -> panic "pprStmt: return statement should have been cps'd away"
-    CmmNop       -> empty
     CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
                           -- XXX if the string contains "*/", we need to fix it
                           -- XXX we probably want to emit these comments when
@@ -191,14 +187,20 @@ pprStmt stmt =
         where
           rep = cmmExprType dflags src
 
-    CmmCall (CmmCallee fn cconv) results args ret ->
+    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
         maybe_proto $$
         fnCall
         where
-        cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
+        ForeignConvention cconv _ _ ret = conv
+
+        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
 
         real_fun_proto lbl = char ';' <>
-                        pprCFunType (ppr lbl) cconv results args <>
+                        pprCFunType (ppr lbl) cconv hresults hargs <>
                         noreturn_attr <> semi
 
         noreturn_attr = case ret of
@@ -210,7 +212,7 @@ pprStmt stmt =
             case fn of
               CmmLit (CmmLabel lbl)
                 | StdCallConv <- cconv ->
-                    let myCall = pprCall (ppr lbl) cconv results args
+                    let myCall = pprCall (ppr lbl) cconv hresults hargs
                     in (real_fun_proto lbl, myCall)
                         -- stdcall functions must be declared with
                         -- a function type, otherwise the C compiler
@@ -218,40 +220,44 @@ pprStmt stmt =
                         -- can't add the @n suffix ourselves, because
                         -- it isn't valid C.
                 | CmmNeverReturns <- ret ->
-                    let myCall = pprCall (ppr lbl) cconv results args
+                    let myCall = pprCall (ppr lbl) cconv hresults hargs
                     in (real_fun_proto lbl, myCall)
                 | not (isMathFun lbl) ->
-                    pprForeignCall (ppr lbl) cconv results args
+                    pprForeignCall (ppr lbl) cconv hresults hargs
               _ ->
                    (empty {- no proto -},
-                    pprCall cast_fn cconv results args <> semi)
+                    pprCall cast_fn cconv hresults hargs <> semi)
                         -- for a dynamic call, no declaration is necessary.
 
-    CmmCall (CmmPrim _ (Just stmts)) _ _ _ ->
-        vcat $ map pprStmt stmts
-
-    CmmCall (CmmPrim op _) results args _ret ->
+    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
         proto $$ fn_call
       where
         cconv = CCallConv
         fn = pprCallishMachOp_for_C op
+
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
         (proto, fn_call)
           -- The mem primops carry an extra alignment arg, must drop it.
           -- We could maybe emit an alignment directive using this info.
           -- We also need to cast mem primops to prevent conflicts with GCC
           -- builtins (see bug #5967).
           | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
-          = pprForeignCall fn cconv results (init args)
+          = pprForeignCall fn cconv hresults (init hargs)
           | otherwise
-          = (empty, pprCall fn cconv results args)
+          = (empty, pprCall fn cconv hresults hargs)
 
     CmmBranch ident          -> pprBranch ident
-    CmmCondBranch expr ident -> pprCondBranch expr ident
-    CmmJump lbl _            -> mkJMP_(pprExpr lbl) <> semi
+    CmmCondBranch expr yes no -> pprCondBranch expr yes no
+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
     CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->
                                 pprSwitch dflags arg ids
 
-pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual]
+type Hinted a = (a, ForeignHint)
+
+pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
                -> (SDoc, SDoc)
 pprForeignCall fn cconv results args = (proto, fn_call)
   where
@@ -263,14 +269,14 @@ pprForeignCall fn cconv results args = (proto, fn_call)
     cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
     proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
 
-pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
+pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
 pprCFunType ppr_fn cconv ress args
   = sdocWithDynFlags $ \dflags ->
     let res_type [] = ptext (sLit "void")
-        res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint
         res_type _ = panic "pprCFunType: only void or 1 return value supported"
 
-        arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint
+        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
     in res_type ress <+>
        parens (ccallConvAttribute cconv <> ppr_fn) <>
        parens (commafy (map arg_type args))
@@ -283,11 +289,11 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
 
 -- ---------------------------------------------------------------------
 -- conditional branches to local labels
-pprCondBranch :: CmmExpr -> BlockId -> SDoc
-pprCondBranch expr ident
+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
+pprCondBranch expr yes no
         = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
-                        ptext (sLit "goto") , (pprBlockId ident) <> semi ]
-
+                        ptext (sLit "goto"), pprBlockId yes,
+                        ptext (sLit "else"), pprBlockId no <> semi ]
 
 -- ---------------------------------------------------------------------
 -- a local table branch
@@ -831,7 +837,7 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
 -- -----------------------------------------------------------------------------
 -- Foreign Calls
 
-pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
+pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
 pprCall ppr_fn cconv results args
   | not (is_cishCC cconv)
   = panic $ "pprCall: unknown calling convention"
@@ -841,18 +847,18 @@ pprCall ppr_fn cconv results args
     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
   where
      ppr_assign []           rhs = rhs
-     ppr_assign [CmmHinted one hint] rhs
+     ppr_assign [(one,hint)] rhs
          = pprLocalReg one <> ptext (sLit " = ")
                  <> pprUnHint hint (localRegType one) <> rhs
      ppr_assign _other _rhs = panic "pprCall: multiple results"
 
-     pprArg (CmmHinted expr AddrHint)
+     pprArg (expr, AddrHint)
         = cCast (ptext (sLit "void *")) expr
         -- see comment by machRepHintCType below
-     pprArg (CmmHinted expr SignedHint)
+     pprArg (expr, SignedHint)
         = sdocWithDynFlags $ \dflags ->
           cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
-     pprArg (CmmHinted expr _other)
+     pprArg (expr, _other)
         = pprExpr expr
 
      pprUnHint AddrHint   rep = parens (machRepCType rep)
@@ -871,7 +877,7 @@ is_cishCC PrimCallConv = False
 -- Find and print local and external declarations for a list of
 -- Cmm statements.
 --
-pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls stmts
   = (vcat (map pprTempDecl (uniqSetToList temps)),
      vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
@@ -930,8 +936,9 @@ te_Static :: CmmStatic -> TE ()
 te_Static (CmmStaticLit lit) = te_Lit lit
 te_Static _ = return ()
 
-te_BB :: CmmBasicBlock -> TE ()
-te_BB (BasicBlock _ ss)         = mapM_ te_Stmt ss
+te_BB :: CmmBlock -> TE ()
+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
+  where (_, mid, last) = blockSplit block
 
 te_Lit :: CmmLit -> TE ()
 te_Lit (CmmLabel l) = te_lbl l
@@ -939,21 +946,21 @@ te_Lit (CmmLabelOff l _) = te_lbl l
 te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1
 te_Lit _ = return ()
 
-te_Stmt :: CmmStmt -> TE ()
+te_Stmt :: CmmNode e x -> TE ()
 te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
 te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r
-te_Stmt (CmmCall target rs es _) = do te_Target target
-                                      mapM_ (te_temp.hintlessCmm) rs
-                                      mapM_ (te_Expr.hintlessCmm) es
-te_Stmt (CmmCondBranch e _)     = te_Expr e
+te_Stmt (CmmUnsafeForeignCall target rs es)
+  = do  te_Target target
+        mapM_ te_temp rs
+        mapM_ te_Expr es
+te_Stmt (CmmCondBranch e _ _)   = te_Expr e
 te_Stmt (CmmSwitch e _)         = te_Expr e
-te_Stmt (CmmJump e _)           = te_Expr e
+te_Stmt (CmmCall { cml_target = e }) = te_Expr e
 te_Stmt _                       = return ()
 
-te_Target :: CmmCallTarget -> TE ()
-te_Target (CmmCallee {})           = return ()
-te_Target (CmmPrim _ Nothing)      = return ()
-te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts
+te_Target :: ForeignTarget -> TE ()
+te_Target (ForeignTarget e _)      = te_Expr e
+te_Target (PrimTarget{})           = return ()
 
 te_Expr :: CmmExpr -> TE ()
 te_Expr (CmmLit lit)            = te_Lit lit
index 7d2f482..71c8446 100644 (file)
@@ -35,7 +35,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module PprCmmExpr
     ( pprExpr, pprLit
-    , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -}
     )
 where
 
index 67d8fd8..bdb7f69 100644 (file)
@@ -6,12 +6,15 @@
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE GADTs #-}
 module CgUtils ( fixStgRegisters ) where
 
 #include "HsVersions.h"
 
 import CodeGen.Platform
-import OldCmm
+import Cmm
+import Hoopl
+import CmmUtils
 import CLabel
 import DynFlags
 import Outputable
@@ -96,59 +99,28 @@ get_Regtable_addr_from_offset dflags _ offset =
 fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
 fixStgRegisters _ top@(CmmData _ _) = top
 
-fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) =
-  let blocks' = map (fixStgRegBlock dflags) blocks
-  in CmmProc info lbl live $ ListGraph blocks'
+fixStgRegisters dflags (CmmProc info lbl live graph) =
+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph
+  in CmmProc info lbl live graph'
 
-fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
-fixStgRegBlock dflags (BasicBlock id stmts) =
-  let stmts' = map (fixStgRegStmt dflags) stmts
-  in BasicBlock id stmts'
+fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x
+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block
 
-fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
-fixStgRegStmt dflags stmt
-  = case stmt of
-        CmmAssign (CmmGlobal reg) src ->
-            let src' = fixStgRegExpr dflags src
-                baseAddr = get_GlobalReg_addr dflags reg
-            in case reg `elem` activeStgRegs platform of
-                True  -> CmmAssign (CmmGlobal reg) src'
-                False -> CmmStore baseAddr src'
-
-        CmmAssign reg src ->
-            let src' = fixStgRegExpr dflags src
-            in CmmAssign reg src'
-
-        CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
-
-        CmmCall target regs args returns ->
-            let target' = case target of
-                    CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
-                    CmmPrim op mStmts ->
-                        CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
-                args' = map (\(CmmHinted arg hint) ->
-                                (CmmHinted (fixStgRegExpr dflags arg) hint)) args
-            in CmmCall target' regs args' returns
-
-        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
-
-        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
+fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
+  where
+    platform = targetPlatform dflags
 
-        CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
-
-        -- CmmNop, CmmComment, CmmBranch, CmmReturn
-        _other -> stmt
-    where platform = targetPlatform dflags
-
-
-fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
-fixStgRegExpr dflags expr
-  = case expr of
-        CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
-
-        CmmMachOp mop args -> CmmMachOp mop args'
-            where args' = map (fixStgRegExpr dflags) args
+    fixAssign stmt =
+      case stmt of
+        CmmAssign (CmmGlobal reg) src ->
+            let baseAddr = get_GlobalReg_addr dflags reg
+            in case reg `elem` activeStgRegs (targetPlatform dflags) of
+                True  -> CmmAssign (CmmGlobal reg) src
+                False -> CmmStore baseAddr src
+        other_stmt -> other_stmt
 
+    fixExpr expr = case expr of
         CmmReg (CmmGlobal reg) ->
             -- Replace register leaves with appropriate StixTrees for
             -- the given target.  MagicIds which map to a reg on this
@@ -161,9 +133,8 @@ fixStgRegExpr dflags expr
                 False ->
                     let baseAddr = get_GlobalReg_addr dflags reg
                     in case reg of
-                        BaseReg -> fixStgRegExpr dflags baseAddr
-                        _other  -> fixStgRegExpr dflags
-                                    (CmmLoad baseAddr (globalRegType dflags reg))
+                        BaseReg -> baseAddr
+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)
 
         CmmRegOff (CmmGlobal reg) offset ->
             -- RegOf leaves are just a shorthand form. If the reg maps
@@ -171,12 +142,10 @@ fixStgRegExpr dflags expr
             -- expand it and defer to the above code.
             case reg `elem` activeStgRegs platform of
                 True  -> expr
-                False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
-                                    CmmReg (CmmGlobal reg),
+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [
+                                    fixExpr (CmmReg (CmmGlobal reg)),
                                     CmmLit (CmmInt (fromIntegral offset)
-                                                (wordWidth dflags))])
+                                                   (wordWidth dflags))]
 
-        -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
-        _other -> expr
-    where platform = targetPlatform dflags
+        other_expr -> other_expr
 
index 1a10cd1..d2ef375 100644 (file)
@@ -173,7 +173,6 @@ Library
         CmmCallConv
         CmmCommonBlockElim
         CmmContFlowOpt
-        CmmCvt
         CmmExpr
         CmmInfo
         CmmLex
@@ -190,10 +189,6 @@ Library
         CmmUtils
         CmmLayoutStack
         MkGraph
-        OldCmm
-        OldCmmLint
-        OldCmmUtils
-        OldPprCmm
         PprBase
         PprC
         PprCmm
index 571348f..241e52e 100644 (file)
@@ -14,8 +14,9 @@ import LlvmCodeGen.Ppr
 import LlvmMangler
 
 import CgUtils ( fixStgRegisters )
-import OldCmm
-import OldPprCmm
+import Cmm
+import Hoopl
+import PprCmm
 
 import BufWrite
 import DynFlags
@@ -41,10 +42,11 @@ llvmCodeGen dflags h us cmms
         (cdata,env) = {-# SCC "llvm_split" #-}
                       foldr split ([], initLlvmEnv dflags) cmm
         split (CmmData s d' ) (d,e) = ((s,d'):d,e)
-        split p@(CmmProc _ l live _) (d,e) =
-            let lbl = strCLabel_llvm env $ case topInfoTable p of
-                        Nothing                   -> l
-                        Just (Statics info_lbl _) -> info_lbl
+        split p@(CmmProc h l live g) (d,e) =
+            let lbl = strCLabel_llvm env $
+                        case mapLookup (g_entry g) h of
+                          Nothing                   -> l
+                          Just (Statics info_lbl _) -> info_lbl
                 env' = funInsert lbl (llvmFunTy dflags live) e
             in (d,env')
     in do
@@ -129,9 +131,6 @@ cmmProcLlvmGens dflags h _ _ [] _ ivars
 cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
  = cmmProcLlvmGens dflags h us env cmms count ivars
 
-cmmProcLlvmGens dflags h us env ((CmmProc _ _ _ (ListGraph [])) : cmms) count ivars
- = cmmProcLlvmGens dflags h us env cmms count ivars
-
 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
     (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
     let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
index 849e40d..56537d2 100644 (file)
@@ -34,7 +34,7 @@ import CLabel
 import CodeGen.Platform ( activeStgRegs )
 import DynFlags
 import FastString
-import OldCmm
+import Cmm
 import qualified Outputable as Outp
 import Platform
 import UniqFM
index d62fbf4..b5d4b4a 100644 (file)
@@ -3,6 +3,7 @@
 -- | Handle conversion of CmmProc to LLVM code.
 --
 
+{-# LANGUAGE GADTs #-}
 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
 
 #include "HsVersions.h"
@@ -14,8 +15,10 @@ import LlvmCodeGen.Regs
 import BlockId
 import CodeGen.Platform ( activeStgRegs, callerSaves )
 import CLabel
-import OldCmm
-import qualified OldPprCmm as PprCmm
+import Cmm
+import PprCmm
+import CmmUtils
+import Hoopl
 
 import DynFlags
 import FastString
@@ -37,9 +40,10 @@ type LlvmStatements = OrdList LlvmStatement
 -- | Top-level of the LLVM proc Code generator
 --
 genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
-genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do
+genLlvmProc env proc0@(CmmProc infos lbl live graph) = do
+    let blocks = toBlockList graph
     (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
-    let info = topInfoTable proc0
+    let info = mapLookup (g_entry graph) infos
         proc = CmmProc info lbl live (ListGraph lmblocks)
     return (env', proc:lmdata)
 
@@ -52,22 +56,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
 -- | Generate code for a list of blocks that make up a complete procedure.
 basicBlocksCodeGen :: LlvmEnv
                    -> LiveGlobalRegs
-                   -> [CmmBasicBlock]
+                   -> [CmmBlock]
                    -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
                    -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
-basicBlocksCodeGen env live ([]) (blocks, tops)
-  = do let dflags = getDflags env
-       let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
-       let allocs' = concat allocs
-       let ((BasicBlock id fstmts):rblks) = blocks'
-       let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
-       return (env, fblocks, tops)
-
-basicBlocksCodeGen env live (block:blocks) (lblocks', ltops')
+basicBlocksCodeGen env live [] (blocks0, tops0)
+  = return (env, fblocks, tops)
+  where
+     dflags   = getDflags env
+     blocks   = reverse blocks0
+     tops     = reverse tops0
+     (blocks', allocs) = mapAndUnzip dominateAllocs blocks
+     allocs'  = concat allocs
+     (BasicBlock id fstmts : rblks) = blocks'
+     fblocks  = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
+
+basicBlocksCodeGen env live (block:blocks) (lblocks, ltops)
   = do (env', lb, lt) <- basicBlockCodeGen env block
-       let lblocks = lblocks' ++ lb
-       let ltops   = ltops' ++ lt
-       basicBlocksCodeGen env' live blocks (lblocks, ltops)
+       basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops)
 
 
 -- | Allocations need to be extracted so they can be moved to the entry
@@ -81,16 +86,19 @@ dominateAllocs (BasicBlock id stmts)
 
 
 -- | Generate code for one block
-basicBlockCodeGen ::  LlvmEnv
-                  -> CmmBasicBlock
-                  -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmDecl] )
-basicBlockCodeGen env (BasicBlock id stmts)
-  = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
-       return (env', [BasicBlock id (fromOL instrs)], top)
-
+basicBlockCodeGen :: LlvmEnv
+                  -> CmmBlock
+                  -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen env block
+  = do let (CmmEntry id, nodes, tail)  = blockSplit block
+       let stmts = blockToList nodes
+       (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
+       (env'', tail_instrs, top')  <- stmtToInstrs env' tail
+       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
+       return (env'', BasicBlock id instrs, top' ++ top)
 
 -- -----------------------------------------------------------------------------
--- * CmmStmt code generation
+-- * CmmNode code generation
 --
 
 -- A statement conversion return data.
@@ -100,8 +108,8 @@ basicBlockCodeGen env (BasicBlock id stmts)
 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl])
 
 
--- | Convert a list of CmmStmt's to LlvmStatement's
-stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmDecl])
+-- | Convert a list of CmmNode's to LlvmStatement's
+stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl])
               -> UniqSM StmtData
 stmtsToInstrs env [] (llvm, top)
   = return (env, llvm, top)
@@ -111,34 +119,28 @@ stmtsToInstrs env (stmt : stmts) (llvm, top)
         stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
 
 
--- | Convert a CmmStmt to a list of LlvmStatement's
-stmtToInstrs :: LlvmEnv -> CmmStmt
+-- | Convert a CmmNode to a list of LlvmStatement's
+stmtToInstrs :: LlvmEnv -> CmmNode e x
              -> UniqSM StmtData
 stmtToInstrs env stmt = case stmt of
 
-    CmmNop               -> return (env, nilOL, [])
     CmmComment _         -> return (env, nilOL, []) -- nuke comments
 
     CmmAssign reg src    -> genAssign env reg src
     CmmStore addr src    -> genStore env addr src
 
     CmmBranch id         -> genBranch env id
-    CmmCondBranch arg id -> genCondBranch env arg id
+    CmmCondBranch arg true false -> genCondBranch env arg true false
     CmmSwitch arg ids    -> genSwitch env arg ids
 
     -- Foreign Call
-    CmmCall target res args ret
-        -> genCall env target res args ret
+    CmmUnsafeForeignCall target res args -> genCall env target res args
 
     -- Tail call
-    CmmJump arg live     -> genJump env arg live
-
-    -- CPS, only tail calls, no return's
-    -- Actually, there are a few return statements that occur because of hand
-    -- written Cmm code.
-    CmmReturn
-        -> return (env, unitOL $ Return Nothing, [])
+    CmmCall { cml_target = arg,
+              cml_args_regs = live } -> genJump env arg live
 
+    _ -> panic "Llvm.CodeGen.stmtToInstrs"
 
 -- | Memory barrier instruction for LLVM >= 3.0
 barrier :: LlvmEnv -> UniqSM StmtData
@@ -171,12 +173,12 @@ oldBarrier env = do
         lmTrue  = mkIntLit i1 (-1)
 
 -- | Foreign Calls
-genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
-              -> CmmReturnInfo -> UniqSM StmtData
+genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> UniqSM StmtData
 
 -- Write barrier needs to be handled specially as it is implemented as an LLVM
 -- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier _) _ _ _
+genCall env (PrimTarget MO_WriteBarrier) _ _
  | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
     = return (env, nilOL, [])
  | getLlvmVer env > 29 = barrier env
@@ -186,7 +188,7 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
 -- is strict about types.
-genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
+genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do
     let dflags = getDflags env
         width = widthToLlvmInt w
         dstTy = cmmToLlvmType $ localRegType dst
@@ -194,7 +196,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
                           CC_Ccc width FixedArgs (tysToParams [width]) Nothing
         (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
 
-    (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, [])
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, [])
     (env3, fptr, stmts3, top3)  <- getFunPtr env2 funTy t
     (argsV', stmts4)            <- castVars dflags $ zip argsV [width]
     (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
@@ -207,7 +211,7 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
 
 -- Handle memcpy function specifically since llvm's intrinsic version takes
 -- some extra parameters.
-genCall env t@(CmmPrim op _) [] args' CmmMayReturn
+genCall env t@(PrimTarget op) [] args'
  | op == MO_Memcpy ||
    op == MO_Memset ||
    op == MO_Memmove = do
@@ -220,7 +224,9 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
         funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                              CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
 
-    (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy t
     (argVars', stmts3)            <- castVars dflags $ zip argVars argTy
 
@@ -236,48 +242,43 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
     -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
     -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
     -- memcpy & co llvm intrinsic functions. So we handle this directly now.
-    extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i
+    extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i
     extractLit _other = trace ("WARNING: Non constant alignment value given" ++ 
                                " for memcpy! Please report to GHC developers")
                         mkIntLit i32 0
 
-genCall env (CmmPrim _ (Just stmts)) _ _ _
-    = stmtsToInstrs env stmts (nilOL, [])
-
 -- Handle all other foreign calls and prim ops.
-genCall env target res args ret = do
+genCall env target res args = do
 
     let dflags = getDflags env
 
     -- parameter types
-    let arg_type (CmmHinted _ AddrHint) = i8Ptr
+    let arg_type (_, AddrHint) = i8Ptr
         -- cast pointers to i8*. Llvm equivalent of void*
-        arg_type (CmmHinted expr _    ) = cmmToLlvmType $ cmmExprType dflags expr
+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
 
     -- ret type
-    let ret_type ([]) = LMVoid
-        ret_type ([CmmHinted _ AddrHint]) = i8Ptr
-        ret_type ([CmmHinted reg _])      = cmmToLlvmType $ localRegType reg
+    let ret_type [] = LMVoid
+        ret_type [(_, AddrHint)] = i8Ptr
+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
         ret_type t = panic $ "genCall: Too many return values! Can only handle"
                         ++ " 0 or 1, given " ++ show (length t) ++ "."
 
-    -- extract Cmm call convention
-    let cconv = case target of
-            CmmCallee _ conv -> conv
-            CmmPrim   _ _    -> PrimCallConv
-
-    -- translate to LLVM call convention
-    let lmconv = case cconv of
-            StdCallConv  -> case platformArch (getLlvmPlatform env) of
-                            ArchX86    -> CC_X86_Stdcc
-                            ArchX86_64 -> CC_X86_Stdcc
-                            _          -> CC_Ccc
-            CCallConv    -> CC_Ccc
-            CApiConv     -> CC_Ccc
-            PrimCallConv -> CC_Ccc
+    -- extract Cmm call convention, and translate to LLVM call convention
+    let lmconv = case target of
+            ForeignTarget _ (ForeignConvention conv _ _ _) ->
+              case conv of
+                 StdCallConv  -> case platformArch (getLlvmPlatform env) of
+                                 ArchX86    -> CC_X86_Stdcc
+                                 ArchX86_64 -> CC_X86_Stdcc
+                                 _          -> CC_Ccc
+                 CCallConv    -> CC_Ccc
+                 CApiConv     -> CC_Ccc
+
+            PrimTarget   _ -> CC_Ccc
 
     {-
-        Some of the possibilities here are a worry with the use of a custom
+        CC_Ccc of the possibilities here are a worry with the use of a custom
         calling convention for passing STG args. In practice the more
         dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
 
@@ -285,23 +286,31 @@ genCall env target res args ret = do
     -}
 
     -- call attributes
-    let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
-                | otherwise              = llvmStdFunAttrs
+    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
+                | otherwise     = llvmStdFunAttrs
+
+        never_returns = case target of
+             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
+             _ -> False
 
     -- fun type
+    let (res_hints, arg_hints) = foreignTargetHints target
+    let args_hints = zip args arg_hints
+    let ress_hints = zip res  res_hints
     let ccTy  = StdCall -- tail calls should be done through CmmJump
-    let retTy = ret_type res
-    let argTy = tysToParams $ map arg_type args
+    let retTy = ret_type ress_hints
+    let argTy = tysToParams $ map arg_type args_hints
     let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                              lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
 
 
-    (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+
+    (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy target
 
-    let retStmt | ccTy == TailCall       = unitOL $ Return Nothing
-                | ret == CmmNeverReturns = unitOL $ Unreachable
-                | otherwise              = nilOL
+    let retStmt | ccTy == TailCall  = unitOL $ Return Nothing
+                | never_returns     = unitOL $ Unreachable
+                | otherwise         = nilOL
 
     let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env)
 
@@ -315,10 +324,10 @@ genCall env target res args ret = do
         _ -> do
             (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
             -- get the return register
-            let ret_reg ([CmmHinted reg hint]) = (reg, hint)
+            let ret_reg [reg] = reg
                 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
                                 ++ " 1, given " ++ show (length t) ++ "."
-            let (creg, _) = ret_reg res
+            let creg = ret_reg res
             let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
             let allStmts = stmts `snocOL` s1 `appOL` stmts3
             if retTy == pLower (getVarType vreg)
@@ -342,12 +351,12 @@ genCall env target res args ret = do
 
 
 -- | Create a function pointer from a target.
-getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
+getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget
           -> UniqSM ExprData
 getFunPtr env funTy targ = case targ of
-    CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
+    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
 
-    CmmCallee expr _ -> do
+    ForeignTarget expr _ -> do
         (env', v1, stmts, top) <- exprToVar env expr
         let fty = funTy $ fsLit "dynamic"
             cast = case getVarType v1 of
@@ -360,7 +369,7 @@ getFunPtr env funTy targ = case targ of
         (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
         return (env', v2, stmts `snocOL` s1, top)
 
-    CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop
+    PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop
 
     where
         litCase name = do
@@ -392,14 +401,14 @@ getFunPtr env funTy targ = case targ of
 
 -- | Conversion of call arguments.
 arg_vars :: LlvmEnv
-         -> [HintedCmmActual]
+         -> [(CmmActual, ForeignHint)]
          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
          -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl])
 
 arg_vars env [] (vars, stmts, tops)
   = return (env, vars, stmts, tops)
 
-arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
+arg_vars env ((e, AddrHint):rest) (vars, stmts, tops)
   = do (env', v1, stmts', top') <- exprToVar env e
        let op = case getVarType v1 of
                ty | isPointer ty -> LM_Bitcast
@@ -412,7 +421,7 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
        arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
                                tops ++ top')
 
-arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
+arg_vars env ((e, _):rest) (vars, stmts, tops)
   = do (env', v1, stmts', top') <- exprToVar env e
        arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
 
@@ -673,17 +682,15 @@ genBranch env id =
 
 
 -- | Conditional branch
-genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
-genCondBranch env cond idT = do
-    idF <- getUniqueUs
+genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
+genCondBranch env cond idT idF = do
     let labelT = blockIdToLlvm idT
-    let labelF = LMLocalVar idF LMLabel
+    let labelF = blockIdToLlvm idF
     (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
     if getVarType vc == i1
         then do
             let s1 = BranchIf vc labelT labelF
-            let s2 = MkLabel idF
-            return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
+            return $ (env', stmts `snocOL` s1, top)
         else
             panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
 
index 9c57ab3..fd0d7cc 100644 (file)
@@ -13,7 +13,7 @@ import LlvmCodeGen.Base
 
 import BlockId
 import CLabel
-import OldCmm
+import Cmm
 
 import FastString
 import qualified Outputable
index 73632f5..218870a 100644 (file)
@@ -14,7 +14,7 @@ import LlvmCodeGen.Data
 import LlvmCodeGen.Regs
 
 import CLabel
-import OldCmm
+import Cmm
 import Platform
 
 import FastString
index beaf7c8..230ba71 100644 (file)
@@ -15,9 +15,9 @@ import UniqSupply       ( mkSplitUniqSupply )
 
 import Finder           ( mkStubPaths )
 import PprC             ( writeCs )
-import OldCmmLint       ( cmmLint )
+import CmmLint          ( cmmLint )
 import Packages
-import OldCmm           ( RawCmmGroup )
+import Cmm              ( RawCmmGroup )
 import HscTypes
 import DynFlags
 import Config
index ab48d35..fe827e3 100644 (file)
@@ -119,13 +119,11 @@ import ProfInit
 import TyCon
 import Name
 import SimplStg         ( stg2stg )
-import qualified OldCmm as Old
-import qualified Cmm as New
+import Cmm
 import CmmParse         ( parseCmmFile )
 import CmmBuildInfoTables
 import CmmPipeline
 import CmmInfo
-import CmmCvt
 import CodeOutput
 import NameEnv          ( emptyNameEnv )
 import NameSet          ( emptyNameSet )
@@ -1353,7 +1351,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
         let initTopSRT = initUs_ us emptySRT
         dumpIfSet_dyn dflags Opt_D_dump_cmmz "Parsed Cmm" (ppr cmm)
         (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
-        rawCmms <- cmmToRawCmm dflags (Stream.yield (cmmOfZgraph cmmgroup))
+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
         return ()
   where
@@ -1368,7 +1366,7 @@ tryNewCodeGen   :: HscEnv -> Module -> [TyCon]
                 -> CollectedCCs
                 -> [StgBinding]
                 -> HpcInfo
-                -> IO (Stream IO Old.CmmGroup ())
+                -> IO (Stream IO CmmGroup ())
          -- Note we produce a 'Stream' of CmmGroups, so that the
          -- backend can be run incrementally.  Otherwise it generates all
          -- the C-- up front, which has a significant space cost.
@@ -1376,7 +1374,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
               cost_centre_info stg_binds hpc_info = do
     let dflags = hsc_dflags hsc_env
 
-    let cmm_stream :: Stream IO New.CmmGroup ()
+    let cmm_stream :: Stream IO CmmGroup ()
         cmm_stream = {-# SCC "StgCmm" #-}
             StgCmm.codeGen dflags this_mod data_tycons
                            cost_centre_info stg_binds hpc_info
@@ -1407,7 +1405,7 @@ tryNewCodeGen hsc_env this_mod data_tycons
                 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
                 let srt | isEmptySRT topSRT = []
                         | otherwise         = srtToData topSRT
-                return (us',cmmOfZgraph (srt ++ cmmgroup))
+                return (us', srt ++ cmmgroup)
 
           in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
                 return ()
@@ -1418,10 +1416,10 @@ tryNewCodeGen hsc_env this_mod data_tycons
   
           let run_pipeline topSRT cmmgroup = do
                 (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT cmmgroup
-                return (topSRT,cmmOfZgraph cmmgroup)
+                return (topSRT,cmmgroup)
   
           in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
-                Stream.yield (cmmOfZgraph (srtToData topSRT))
+                Stream.yield (srtToData topSRT)
 
     let
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a
index 23aca92..7710691 100644 (file)
@@ -7,6 +7,7 @@
 -- -----------------------------------------------------------------------------
 
 \begin{code}
+{-# LANGUAGE GADTs #-}
 module AsmCodeGen ( nativeCodeGen ) where
 
 #include "HsVersions.h"
@@ -50,9 +51,11 @@ import NCGMonad
 
 import BlockId
 import CgUtils          ( fixStgRegisters )
-import OldCmm
+import Cmm
+import CmmUtils
+import Hoopl
 import CmmOpt           ( cmmMachOpFold )
-import OldPprCmm
+import PprCmm
 import CLabel
 
 import UniqFM
@@ -290,8 +293,8 @@ nativeCodeGen' dflags ncgImpl h us cmms
                 | gopt Opt_SplitObjs dflags = split_marker : tops
                 | otherwise                 = tops
 
-        split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] (ListGraph [])
-
+        split_marker = CmmProc mapEmpty mkSplitMarkerLabel []
+                               (ofBlockList (panic "split_marker_entry") [])
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
               => DynFlags
@@ -878,9 +881,9 @@ Ideas for other things we could do (put these in Hoopl please!):
 
 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl live (ListGraph blocks)) = runCmmOpt dflags $ do
-  blocks' <- mapM cmmBlockConFold blocks
-  return $ CmmProc info lbl live (ListGraph blocks')
+cmmToCmm dflags (CmmProc info lbl live graph) = runCmmOpt dflags $ do
+  blocks' <- mapM cmmBlockConFold (toBlockList graph)
+  return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 
@@ -903,10 +906,13 @@ runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
 runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
                         (# result, imports #) -> (result, imports)
 
-cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
-cmmBlockConFold (BasicBlock id stmts) = do
+cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
+cmmBlockConFold block = do
+  let (entry, middle, last) = blockSplit block
+      stmts = blockToList middle
   stmts' <- mapM cmmStmtConFold stmts
-  return $ BasicBlock id stmts'
+  last' <- cmmStmtConFold last
+  return $ blockJoin entry (blockFromList stmts') last'
 
 -- This does three optimizations, but they're very quick to check, so we don't
 -- bother turning them off even when the Hoopl code is active.  Since
@@ -917,13 +923,13 @@ cmmBlockConFold (BasicBlock id stmts) = do
 -- We might be tempted to skip this step entirely of not Opt_PIC, but
 -- there is some PowerPC code for the non-PIC case, which would also
 -- have to be separated.
-cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
+cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
 cmmStmtConFold stmt
    = case stmt of
         CmmAssign reg src
            -> do src' <- cmmExprConFold DataReference src
                  return $ case src' of
-                   CmmReg reg' | reg == reg' -> CmmNop
+                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
                    new_src -> CmmAssign reg new_src
 
         CmmStore addr src
@@ -931,35 +937,27 @@ cmmStmtConFold stmt
                  src'  <- cmmExprConFold DataReference src
                  return $ CmmStore addr' src'
 
-        CmmJump addr live
+        CmmCall { cml_target = addr }
            -> do addr' <- cmmExprConFold JumpReference addr
-                 return $ CmmJump addr' live
+                 return $ stmt { cml_target = addr' }
 
-        CmmCall target regs args returns
+        CmmUnsafeForeignCall target regs args
            -> do target' <- case target of
-                              CmmCallee e conv -> do
+                              ForeignTarget e conv -> do
                                 e' <- cmmExprConFold CallReference e
-                                return $ CmmCallee e' conv
-                              op@(CmmPrim _ Nothing) ->
-                                return op
-                              CmmPrim op (Just stmts) ->
-                                do stmts' <- mapM cmmStmtConFold stmts
-                                   return $ CmmPrim op (Just stmts')
-                 args' <- mapM (\(CmmHinted arg hint) -> do
-                                  arg' <- cmmExprConFold DataReference arg
-                                  return (CmmHinted arg' hint)) args
-                 return $ CmmCall target' regs args' returns
-
-        CmmCondBranch test dest
+                                return $ ForeignTarget e' conv
+                              PrimTarget _ ->
+                                return target
+                 args' <- mapM (cmmExprConFold DataReference) args
+                 return $ CmmUnsafeForeignCall target' regs args'
+
+        CmmCondBranch test true false
            -> do test' <- cmmExprConFold DataReference test
                  dflags <- getDynFlags
                  return $ case test' of
-                   CmmLit (CmmInt 0 _) ->
-                     CmmComment (mkFastString ("deleted: " ++
-                                        showSDoc dflags (pprStmt stmt)))
-
-                   CmmLit (CmmInt _ _) -> CmmBranch dest
-                   _other -> CmmCondBranch test' dest
+                   CmmLit (CmmInt 0 _) -> CmmBranch false
+                   CmmLit (CmmInt _ _) -> CmmBranch true
+                   _other -> CmmCondBranch test' true false
 
         CmmSwitch expr ids
            -> do expr' <- cmmExprConFold DataReference expr
index 86f5ae4..48d6a33 100644 (file)
@@ -2,9 +2,12 @@
 module Instruction (
         RegUsage(..),
         noUsage,
+        GenBasicBlock(..), blockId,
+        ListGraph(..),
         NatCmm,
         NatCmmDecl,
         NatBasicBlock,
+        topInfoTable,
         Instruction(..)
 )
 
@@ -14,8 +17,9 @@ import Reg
 
 import BlockId
 import DynFlags
-import OldCmm
+import Cmm hiding (topInfoTable)
 import Platform
+import Outputable
 
 -- | Holds a list of source and destination registers used by a
 --      particular instruction.
@@ -34,7 +38,6 @@ data RegUsage
 noUsage :: RegUsage
 noUsage  = RU [] []
 
-
 -- Our flavours of the Cmm types
 -- Type synonyms for Cmm populated with native code
 type NatCmm instr
@@ -54,6 +57,13 @@ type NatBasicBlock instr
         = GenBasicBlock instr
 
 
+-- | Returns the info table associated with the CmmDecl's entry point,
+-- if any.
+topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
+topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
+  = mapLookup (blockId b) infos
+topInfoTable _
+  = Nothing
 
 
 -- | Common things that we can do with instructions, on all architectures.
index 69f3e29..e346e7b 100644 (file)
@@ -59,7 +59,7 @@ import NCGMonad
 
 
 import Hoopl
-import OldCmm
+import Cmm
 import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
                           mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
                           dynamicLinkerLabelInfo, mkPicBaseLabel,
index 848c7f9..5e05047 100644 (file)
@@ -12,6 +12,7 @@
 -- (c) the #if blah_TARGET_ARCH} things, the
 -- structure should not be too overwhelming.
 
+{-# LANGUAGE GADTs #-}
 module PPC.CodeGen (
         cmmTopCodeGen,
         generateJumpTableForInstr,
@@ -42,8 +43,10 @@ import Platform
 -- Our intermediate code:
 import BlockId
 import PprCmm           ( pprExpr )
-import OldCmm
+import Cmm
+import CmmUtils
 import CLabel
+import Hoopl
 
 -- The rest:
 import OrdList
@@ -71,7 +74,8 @@ cmmTopCodeGen
         :: RawCmmDecl
         -> NatM [NatCmmDecl CmmStatics Instr]
 
-cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
   dflags <- getDynFlags
@@ -86,12 +90,16 @@ cmmTopCodeGen (CmmData sec dat) = do
   return [CmmData sec dat]  -- no translation, we just use CmmStatic
 
 basicBlockCodeGen
-        :: CmmBasicBlock
+        :: Block CmmNode C C
         -> NatM ( [NatBasicBlock Instr]
                 , [NatCmmDecl CmmStatics Instr])
 
-basicBlockCodeGen (BasicBlock id stmts) = do
-  instrs <- stmtsToInstrs stmts
+basicBlockCodeGen block = do
+  let (CmmEntry id, nodes, tail)  = blockSplit block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
   -- code generation may introduce new basic block boundaries, which
   -- are indicated by the NEWBLOCK instruction.  We must split up the
   -- instruction stream into basic blocks again.  Also, we extract
@@ -107,16 +115,15 @@ basicBlockCodeGen (BasicBlock id stmts) = do
           = (instr:instrs, blocks, statics)
   return (BasicBlock id top : other_blocks, statics)
 
-stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts
         return (concatOL instrss)
 
-stmtToInstrs :: CmmStmt -> NatM InstrBlock
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
 stmtToInstrs stmt = do
   dflags <- getDynFlags
   case stmt of
-    CmmNop         -> return nilOL
     CmmComment s   -> return (unitOL (COMMENT s))
 
     CmmAssign reg src
@@ -135,16 +142,18 @@ stmtToInstrs stmt = do
         where ty = cmmExprType dflags src
               size = cmmTypeSize ty
 
-    CmmCall target result_regs args _
+    CmmUnsafeForeignCall target result_regs args
        -> genCCall target result_regs args
 
     CmmBranch id          -> genBranch id
-    CmmCondBranch arg id  -> genCondJump id arg
+    CmmCondBranch arg true false -> do b1 <- genCondJump true arg
+                                       b2 <- genBranch false
+                                       return (b1 `appOL` b2)
     CmmSwitch arg ids     -> do dflags <- getDynFlags
                                 genSwitch dflags arg ids
-    CmmJump arg _         -> genJump arg
-    CmmReturn             ->
-      panic "stmtToInstrs: return statement should have been cps'd away"
+    CmmCall { cml_target = arg } -> genJump arg
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
 
 
 --------------------------------------------------------------------------------
@@ -837,9 +846,9 @@ genCondJump id bool = do
 -- (If applicable) Do not fill the delay slots here; you will confuse the
 -- register allocator.
 
-genCCall :: CmmCallTarget            -- function to call
-         -> [HintedCmmFormal]        -- where to put the result
-         -> [HintedCmmActual]        -- arguments (of mixed type)
+genCCall :: ForeignTarget            -- function to call
+         -> [CmmFormal]        -- where to put the result
+         -> [CmmActual]        -- arguments (of mixed type)
          -> NatM InstrBlock
 genCCall target dest_regs argsAndHints
  = do dflags <- getDynFlags
@@ -854,9 +863,9 @@ data GenCCallPlatform = GCPLinux | GCPDarwin
 genCCall'
     :: DynFlags
     -> GenCCallPlatform
-    -> CmmCallTarget            -- function to call
-    -> [HintedCmmFormal]        -- where to put the result
-    -> [HintedCmmActual]        -- arguments (of mixed type)
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
     -> NatM InstrBlock
 
 {-
@@ -897,13 +906,13 @@ genCCall'
 -}
 
 
-genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _
+genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _
  = return $ unitOL LWSYNC
 
-genCCall' _ _ (CmmPrim _ (Just stmts)) _ _
-    = stmtsToInstrs stmts
+genCCall' _ _ (PrimTarget MO_Touch) _ _
+ = return $ nilOL
 
-genCCall' dflags gcp target dest_regs argsAndHints
+genCCall' dflags gcp target dest_regs args0
   = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps)
         -- we rely on argument promotion in the codeGen
     do
@@ -915,9 +924,9 @@ genCCall' dflags gcp target dest_regs argsAndHints
                                                         (toOL []) []
 
         (labelOrExpr, reduceToFF32) <- case target of
-            CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False)
-            CmmCallee expr _ -> return  (Right expr, False)
-            CmmPrim mop _ -> outOfLineMachOp mop
+            ForeignTarget (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False)
+            ForeignTarget expr _ -> return  (Right expr, False)
+            PrimTarget mop -> outOfLineMachOp mop
 
         let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
             codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
@@ -948,17 +957,16 @@ genCCall' dflags gcp target dest_regs argsAndHints
                                 GCPLinux -> roundTo 16 finalStack
 
         -- need to remove alignment information
-        argsAndHints' | CmmPrim mop _ <- target,
+        args | PrimTarget mop <- target,
                         (mop == MO_Memcpy ||
                          mop == MO_Memset ||
                          mop == MO_Memmove)
-                      = init argsAndHints
+                      = init args0
 
                       | otherwise
-                      = argsAndHints
+                      = args0
 
-        args = map hintlessCmm argsAndHints'
-        argReps = map (cmmExprType dflags) args
+        argReps = map (cmmExprType dflags) args0
 
         roundTo a x | x `mod` a == 0 = x
                     | otherwise = x + a - (x `mod` a)
@@ -1086,7 +1094,7 @@ genCCall' dflags gcp target dest_regs argsAndHints
         moveResult reduceToFF32 =
             case dest_regs of
                 [] -> nilOL
-                [CmmHinted dest _hint]
+                [dest]
                     | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)
                     | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
                     | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3,
index 1f5e809..40827d4 100644 (file)
@@ -36,7 +36,7 @@ import Reg
 import CodeGen.Platform
 import BlockId
 import DynFlags
-import OldCmm
+import Cmm
 import FastString
 import CLabel
 import Outputable
index 045ce8d..cbeabdd 100644 (file)
@@ -30,7 +30,7 @@ import Reg
 import RegClass
 import TargetReg
 
-import OldCmm
+import Cmm hiding (topInfoTable)
 import BlockId
 
 import CLabel
index 2b74d1d..0fd93e1 100644 (file)
@@ -29,7 +29,7 @@ where
 import PPC.Instr
 
 import BlockId
-import OldCmm
+import Cmm
 import CLabel
 
 import Unique
index d4123ac..f92351b 100644 (file)
@@ -50,7 +50,7 @@ import Reg
 import RegClass
 import Size
 
-import OldCmm
+import Cmm
 import CLabel           ( CLabel )
 import Unique
 
index c4fb7ac..8a0d216 100644 (file)
@@ -19,7 +19,7 @@ import RegAlloc.Liveness
 import Instruction
 import Reg
 
-import OldCmm
+import Cmm
 import Bag
 import Digraph
 import UniqFM
index 25bd313..dbfde5c 100644 (file)
@@ -11,7 +11,7 @@ where
 import RegAlloc.Liveness
 import Instruction
 import Reg
-import OldCmm hiding (RegSet)
+import Cmm hiding (RegSet)
 import BlockId
 
 import State
index 7f86b9a..a216d97 100644 (file)
@@ -39,7 +39,7 @@ import Instruction
 import Reg
 
 import BlockId
-import OldCmm
+import Cmm
 import UniqSet
 import UniqFM
 import Unique
index 879597f..a2d9e1a 100644 (file)
@@ -31,7 +31,7 @@ import Reg
 import GraphBase
 
 import BlockId
-import OldCmm
+import Cmm
 import UniqFM
 import UniqSet
 import Digraph         (flattenSCCs)
index f85cdb7..61a8400 100644 (file)
@@ -27,8 +27,7 @@ import RegClass
 import Reg
 import TargetReg
 
-import OldCmm
-import OldPprCmm()
+import PprCmm()
 import Outputable
 import UniqFM
 import UniqSet
index 6294743..768ddab 100644 (file)
@@ -17,7 +17,6 @@ import Instruction
 import Reg
 
 import BlockId
-import OldCmm  hiding (RegSet)
 import Digraph
 import DynFlags
 import Outputable
index fc5b992..fa71457 100644 (file)
@@ -116,7 +116,7 @@ import Instruction
 import Reg
 
 import BlockId
-import OldCmm hiding (RegSet)
+import Cmm hiding (RegSet)
 
 import Digraph
 import DynFlags
@@ -743,12 +743,13 @@ allocateRegsAndSpill reading keep spills alloc (r:rs)
                 Just (InMem slot) | reading   -> doSpill (ReadMem slot)
                                   | otherwise -> doSpill WriteMem
                 Nothing | reading   ->
-                   -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
-                   -- ToDo: This case should be a panic, but we
-                   -- sometimes see an unreachable basic block which
-                   -- triggers this because the register allocator
-                   -- will start with an empty assignment.
-                   doSpill WriteNew
+                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
+                   -- NOTE: if the input to the NCG contains some
+                   -- unreachable blocks with junk code, this panic
+                   -- might be triggered.  Make sure you only feed
+                   -- sensible code into the NCG.  In CmmPipeline we
+                   -- call removeUnreachableBlocks at the end for this
+                   -- reason.
 
                         | otherwise -> doSpill WriteNew
 
index bfd196a..d8ca775 100644 (file)
@@ -17,8 +17,6 @@ import RegAlloc.Linear.Base
 import RegAlloc.Liveness
 import Instruction
 
-import OldCmm  (GenBasicBlock(..))
-
 import UniqFM
 import Outputable
 
index 12c1388..f49155e 100644 (file)
@@ -33,8 +33,8 @@ import Reg
 import Instruction
 
 import BlockId
-import OldCmm hiding (RegSet)
-import OldPprCmm()
+import Cmm hiding (RegSet)
+import PprCmm()
 
 import Digraph
 import DynFlags
@@ -690,10 +690,11 @@ regLiveness platform (CmmProc info lbl live sccs)
 
 -- -----------------------------------------------------------------------------
 -- | Check ordering of Blocks
---   The computeLiveness function requires SCCs to be in reverse dependent order.
---   If they're not the liveness information will be wrong, and we'll get a bad allocation.
---   Better to check for this precondition explicitly or some other poor sucker will
---   waste a day staring at bad assembly code..
+--   The computeLiveness function requires SCCs to be in reverse
+--   dependent order.  If they're not the liveness information will be
+--   wrong, and we'll get a bad allocation.  Better to check for this
+--   precondition explicitly or some other poor sucker will waste a
+--   day staring at bad assembly code..
 --
 checkIsReverseDependent
         :: Instruction instr
index c4efdf6..f3b70e7 100644 (file)
@@ -6,6 +6,7 @@
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE GADTs #-}
 module SPARC.CodeGen (
         cmmTopCodeGen,
         generateJumpTableForInstr,
@@ -38,7 +39,9 @@ import NCGMonad
 
 -- Our intermediate code:
 import BlockId
-import OldCmm
+import Cmm
+import CmmUtils
+import Hoopl
 import PIC
 import Reg
 import CLabel
@@ -59,8 +62,9 @@ import Control.Monad    ( mapAndUnzipM )
 cmmTopCodeGen :: RawCmmDecl
               -> NatM [NatCmmDecl CmmStatics Instr]
 
-cmmTopCodeGen (CmmProc info lab live (ListGraph blocks))
- = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+cmmTopCodeGen (CmmProc info lab live graph)
+ = do let blocks = toBlockListEntryFirst graph
+      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
 
       let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
       let tops = proc : concat statics
@@ -76,12 +80,16 @@ cmmTopCodeGen (CmmData sec dat) = do
 --      are indicated by the NEWBLOCK instruction.  We must split up the
 --      instruction stream into basic blocks again.  Also, we extract
 --      LDATAs here too.
-basicBlockCodeGen :: CmmBasicBlock
+basicBlockCodeGen :: CmmBlock
                   -> NatM ( [NatBasicBlock Instr]
                           , [NatCmmDecl CmmStatics Instr])
 
-basicBlockCodeGen cmm@(BasicBlock id stmts) = do
-  instrs <- stmtsToInstrs stmts
+basicBlockCodeGen block = do
+  let (CmmEntry id, nodes, tail)  = blockSplit block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
   let
         (top,other_blocks,statics)
                 = foldrOL mkBlocks ([],[],[]) instrs
@@ -97,24 +105,23 @@ basicBlockCodeGen cmm@(BasicBlock id stmts) = do
 
         -- do intra-block sanity checking
         blocksChecked
-                = map (checkBlock cmm)
+                = map (checkBlock block)
                 $ BasicBlock id top : other_blocks
 
   return (blocksChecked, statics)
 
 
 -- | Convert some Cmm statements to SPARC instructions.
-stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts
         return (concatOL instrss)
 
 
-stmtToInstrs :: CmmStmt -> NatM InstrBlock
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
 stmtToInstrs stmt = do
   dflags <- getDynFlags
   case stmt of
-    CmmNop         -> return nilOL
     CmmComment s   -> return (unitOL (COMMENT s))
 
     CmmAssign reg src
@@ -131,17 +138,19 @@ stmtToInstrs stmt = do
         where ty = cmmExprType dflags src
               size = cmmTypeSize ty
 
-    CmmCall target result_regs args _
+    CmmUnsafeForeignCall target result_regs args
        -> genCCall target result_regs args
 
     CmmBranch   id              -> genBranch id
-    CmmCondBranch arg id        -> genCondJump id arg
+    CmmCondBranch arg true false -> do b1 <- genCondJump true arg
+                                       b2 <- genBranch false
+                                       return (b1 `appOL` b2)
     CmmSwitch   arg ids         -> do dflags <- getDynFlags
                                       genSwitch dflags arg ids
-    CmmJump     arg _           -> genJump arg
+    CmmCall { cml_target = arg } -> genJump arg
 
-    CmmReturn
-     -> panic "stmtToInstrs: return statement should have been cps'd away"
+    _
+     -> panic "stmtToInstrs: statement should have been cps'd away"
 
 
 {-
@@ -369,9 +378,9 @@ generateJumpTableForInstr _ _ = Nothing
 -}
 
 genCCall
-    :: CmmCallTarget            -- function to call
-    -> [HintedCmmFormal]        -- where to put the result
-    -> [HintedCmmActual]        -- arguments (of mixed type)
+    :: ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
     -> NatM InstrBlock
 
 
@@ -382,28 +391,20 @@ genCCall
 --
 -- In the SPARC case we don't need a barrier.
 --
-genCCall (CmmPrim (MO_WriteBarrier) _) _ _
+genCCall (PrimTarget MO_WriteBarrier) _ _
  = do   return nilOL
 
-genCCall (CmmPrim _ (Just stmts)) _ _
-    = stmtsToInstrs stmts
-
-genCCall target dest_regs argsAndHints
+genCCall target dest_regs args0
  = do
         -- need to remove alignment information
-        let argsAndHints' | CmmPrim mop _ <- target,
+        let args | PrimTarget mop <- target,
                             (mop == MO_Memcpy ||
                              mop == MO_Memset ||
                              mop == MO_Memmove)
-                          = init argsAndHints
+                          = init args0
 
                           | otherwise
-                          = argsAndHints
-
-        -- strip hints from the arg regs
-        let args :: [CmmExpr]
-            args  = map hintlessCmm argsAndHints'
-
+                          = args0
 
         -- work out the arguments, and assign them to integer regs
         argcode_and_vregs       <- mapM arg_to_int_vregs args
@@ -416,14 +417,14 @@ genCCall target dest_regs argsAndHints
 
         -- deal with static vs dynamic call targets
         callinsns <- case target of
-                CmmCallee (CmmLit (CmmLabel lbl)) _ ->
+                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->
                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
 
-                CmmCallee expr _
+                ForeignTarget expr _
                  -> do  (dyn_c, [dyn_r]) <- arg_to_int_vregs expr
                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
 
-                CmmPrim mop _
+                PrimTarget mop
                  -> do  res     <- outOfLineMachOp mop
                         lblOrMopExpr <- case res of
                                 Left lbl -> do
@@ -539,11 +540,11 @@ move_final (v:vs) (a:az) offset
 -- | Assign results returned from the call into their
 --      desination regs.
 --
-assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr
+assign_code :: Platform -> [LocalReg] -> OrdList Instr
 
 assign_code _ [] = nilOL
 
-assign_code platform [CmmHinted dest _hint]
+assign_code platform [dest]
  = let  rep     = localRegType dest
         width   = typeWidth rep
         r_dest  = getRegisterReg platform (CmmLocal dest)
index 139064c..7871569 100644 (file)
@@ -22,7 +22,7 @@ import SPARC.Base
 import NCGMonad
 import Size
 
-import OldCmm
+import Cmm
 
 import OrdList
 
index 367d923..16384f1 100644 (file)
@@ -30,8 +30,7 @@ import Reg
 
 import CodeGen.Platform
 import DynFlags
-import OldCmm
-import OldPprCmm ()
+import Cmm
 import Platform
 
 import Outputable
index d459d98..0e94d67 100644 (file)
@@ -24,7 +24,7 @@ import SPARC.Base
 import NCGMonad
 import Size
 
-import OldCmm
+import Cmm
 
 import OrdList
 import Outputable
index fa39777..16b9b42 100644 (file)
@@ -21,7 +21,7 @@ import SPARC.Ppr      ()
 import Instruction
 import Reg
 import Size
-import OldCmm
+import Cmm
 
 
 import Outputable
index f7c7419..3e25536 100644 (file)
@@ -29,7 +29,7 @@ import NCGMonad
 import Size
 import Reg
 
-import OldCmm
+import Cmm
 
 import Control.Monad (liftM)
 import DynFlags
index 7de92cb..43632c6 100644 (file)
@@ -10,7 +10,7 @@ import SPARC.CodeGen.Base
 import NCGMonad
 import Reg
 
-import OldCmm
+import Cmm
 
 getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)
 getRegister :: CmmExpr -> NatM Register
index 654875c..7b39a37 100644 (file)
@@ -28,7 +28,7 @@ import Instruction
 import Size
 import Reg
 
-import OldCmm
+import Cmm
 
 import DynFlags
 import OrdList
index 7eb8bb4..ac8b175 100644 (file)
@@ -19,14 +19,14 @@ import SPARC.Instr
 import SPARC.Ppr       ()
 import Instruction
 
-import OldCmm
+import Cmm
 
 import Outputable
 
 
 -- | Enforce intra-block invariants.
 --
-checkBlock :: CmmBasicBlock
+checkBlock :: CmmBlock
            -> NatBasicBlock Instr
            -> NatBasicBlock Instr
 
index fe64738..77761fc 100644 (file)
@@ -15,7 +15,7 @@ module SPARC.Imm (
 
 where
 
-import OldCmm
+import Cmm
 import CLabel
 
 import Outputable
index f55c660..4896d41 100644 (file)
@@ -47,7 +47,7 @@ import CLabel
 import CodeGen.Platform
 import BlockId
 import DynFlags
-import OldCmm
+import Cmm
 import FastString
 import FastBool
 import Outputable
index 9bfa314..601b528 100644 (file)
@@ -35,8 +35,8 @@ import Reg
 import Size
 import PprBase
 
-import OldCmm
-import OldPprCmm()
+import Cmm hiding (topInfoTable)
+import PprCmm()
 import CLabel
 import BlockId
 
index 5d63fd7..bd66d04 100644 (file)
@@ -21,7 +21,7 @@ import SPARC.Imm
 
 import CLabel
 import BlockId
-import OldCmm
+import Cmm
 
 import Panic
 import Unique
index 99e5de6..66f7422 100644 (file)
@@ -30,7 +30,7 @@ module Size (
 
 where
 
-import OldCmm
+import Cmm
 import Outputable
 
 -- It looks very like the old MachRep, but it's now of purely local
index b3160ed..36f9e2d 100644 (file)
@@ -10,6 +10,7 @@
 -- (a) the sectioning, and (b) the type signatures, the
 -- structure should not be too overwhelming.
 
+{-# LANGUAGE GADTs #-}
 module X86.CodeGen (
         cmmTopCodeGen,
         generateJumpTableForInstr,
@@ -41,8 +42,9 @@ import BasicTypes
 import BlockId
 import Module           ( primPackageId )
 import PprCmm           ()
-import OldCmm
-import OldPprCmm        ()
+import CmmUtils
+import Cmm
+import Hoopl
 import CLabel
 
 -- The rest:
@@ -93,7 +95,8 @@ cmmTopCodeGen
         :: RawCmmDecl
         -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
 
-cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
   dflags <- getDynFlags
@@ -110,12 +113,16 @@ cmmTopCodeGen (CmmData sec dat) = do
 
 
 basicBlockCodeGen
-        :: CmmBasicBlock
+        :: CmmBlock
         -> NatM ( [NatBasicBlock Instr]
                 , [NatCmmDecl (Alignment, CmmStatics) Instr])
 
-basicBlockCodeGen (BasicBlock id stmts) = do
-  instrs <- stmtsToInstrs stmts
+basicBlockCodeGen block = do
+  let (CmmEntry id, nodes, tail)  = blockSplit block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
   -- code generation may introduce new basic block boundaries, which
   -- are indicated by the NEWBLOCK instruction.  We must split up the
   -- instruction stream into basic blocks again.  Also, we extract
@@ -132,18 +139,17 @@ basicBlockCodeGen (BasicBlock id stmts) = do
   return (BasicBlock id top : other_blocks, statics)
 
 
-stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts
         return (concatOL instrss)
 
 
-stmtToInstrs :: CmmStmt -> NatM InstrBlock
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
 stmtToInstrs stmt = do
   dflags <- getDynFlags
   is32Bit <- is32BitPlatform
   case stmt of
-    CmmNop         -> return nilOL
     CmmComment s   -> return (unitOL (COMMENT s))
 
     CmmAssign reg src
@@ -160,17 +166,21 @@ stmtToInstrs stmt = do
         where ty = cmmExprType dflags src
               size = cmmTypeSize ty
 
-    CmmCall target result_regs args _
+    CmmUnsafeForeignCall target result_regs args
        -> genCCall is32Bit target result_regs args
 
     CmmBranch id          -> genBranch id
-    CmmCondBranch arg id  -> genCondJump id arg
+    CmmCondBranch arg true false -> do b1 <- genCondJump true arg
+                                       b2 <- genBranch false
+                                       return (b1 `appOL` b2)
     CmmSwitch arg ids     -> do dflags <- getDynFlags
                                 genSwitch dflags arg ids
-    CmmJump arg gregs     -> do dflags <- getDynFlags
+    CmmCall { cml_target = arg
+            , cml_args_regs = gregs } -> do
+                                dflags <- getDynFlags
                                 genJump arg (jumpRegs dflags gregs)
-    CmmReturn             ->
-      panic "stmtToInstrs: return statement should have been cps'd away"
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
 
 
 jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
@@ -1523,9 +1533,9 @@ genCondJump id bool = do
 
 genCCall
     :: Bool                     -- 32 bit platform?
-    -> CmmCallTarget            -- function to call
-    -> [HintedCmmFormal]        -- where to put the result
-    -> [HintedCmmActual]        -- arguments (of mixed type)
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
     -> NatM InstrBlock
 
 -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@@ -1533,10 +1543,10 @@ genCCall
 -- Unroll memcpy calls if the source and destination pointers are at
 -- least DWORD aligned and the number of bytes to copy isn't too
 -- large.  Otherwise, call C's memcpy.
-genCCall is32Bit (CmmPrim MO_Memcpy _) _
-         [CmmHinted dst _, CmmHinted src _,
-          CmmHinted (CmmLit (CmmInt n _)) _,
-          CmmHinted (CmmLit (CmmInt align _)) _]
+genCCall is32Bit (PrimTarget MO_Memcpy) _
+         [dst, src,
+          (CmmLit (CmmInt n _)),
+          (CmmLit (CmmInt align _))]
     | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do
         code_dst <- getAnyReg dst
         dst_r <- getNewRegNat size
@@ -1576,11 +1586,11 @@ genCCall is32Bit (CmmPrim MO_Memcpy _) _
         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
                    (ImmInteger (n - i))
 
-genCCall _ (CmmPrim MO_Memset _) _
-         [CmmHinted dst _,
-          CmmHinted (CmmLit (CmmInt c _)) _,
-          CmmHinted (CmmLit (CmmInt n _)) _,
-          CmmHinted (CmmLit (CmmInt align _)) _]
+genCCall _ (PrimTarget MO_Memset) _
+         [dst,
+          CmmLit (CmmInt c _),
+          CmmLit (CmmInt n _),
+          CmmLit (CmmInt align _)]
     | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do
         code_dst <- getAnyReg dst
         dst_r <- getNewRegNat size
@@ -1615,12 +1625,14 @@ genCCall _ (CmmPrim MO_Memset _) _
         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
                    (ImmInteger (n - i))
 
-genCCall _ (CmmPrim MO_WriteBarrier _) _ _ = return nilOL
+genCCall _ (PrimTarget MO_WriteBarrier) _ _ = return nilOL
         -- write barrier compiles to no code on x86/x86-64;
         -- we keep it this long in order to prevent earlier optimisations.
 
-genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _]
-         args@[CmmHinted src _] = do
+genCCall _ (PrimTarget MO_Touch) _ _ = return nilOL
+
+genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
+         args@[src] = do
     sse4_2 <- sse4_2Enabled
     dflags <- getDynFlags
     let platform = targetPlatform dflags
@@ -1639,7 +1651,9 @@ genCCall is32Bit (CmmPrim (MO_PopCnt width) _) dest_regs@[CmmHinted dst _]
         else do
             targetExpr <- cmmMakeDynamicReference dflags addImportNat
                           CallReference lbl
-            let target = CmmCallee targetExpr CCallConv
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
             genCCall is32Bit target dest_regs args
   where
     size = intSize width
@@ -1649,25 +1663,25 @@ genCCall is32Bit target dest_regs args
  | is32Bit   = genCCall32 target dest_regs args
  | otherwise = genCCall64 target dest_regs args
 
-genCCall32 :: CmmCallTarget            -- function to call
-           -> [HintedCmmFormal]        -- where to put the result
-           -> [HintedCmmActual]        -- arguments (of mixed type)
+genCCall32 :: ForeignTarget            -- function to call
+           -> [CmmFormal]        -- where to put the result
+           -> [CmmActual]        -- arguments (of mixed type)
            -> NatM InstrBlock
 genCCall32 target dest_regs args = do
   dflags <- getDynFlags
   let platform = targetPlatform dflags
   case (target, dest_regs) of
     -- void return type prim op
-    (CmmPrim op _, []) ->
+    (PrimTarget op, []) ->
         outOfLineCmmOp op Nothing args
     -- we only cope with a single result for foreign calls
-    (CmmPrim op _, [r_hinted@(CmmHinted r _)]) -> do
+    (PrimTarget op, [r]) -> do
         l1 <- getNewLabelNat
         l2 <- getNewLabelNat
         sse2 <- sse2Enabled
         if sse2
           then
-            outOfLineCmmOp op (Just r_hinted) args
+            outOfLineCmmOp op (Just r) args
           else case op of
               MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
               MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
@@ -1681,10 +1695,10 @@ genCCall32 target dest_regs args = do
               MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
               MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
 
-              _other_op   -> outOfLineCmmOp op (Just r_hinted) args
+              _other_op   -> outOfLineCmmOp op (Just r) args
 
        where
-        actuallyInlineFloatOp instr size [CmmHinted x _]
+        actuallyInlineFloatOp instr size [x]
               = do res <- trivialUFCode size (instr size) x
                    any <- anyReg res
                    return (any (getRegisterReg platform False (CmmLocal r)))
@@ -1693,12 +1707,12 @@ genCCall32 target dest_regs args = do
               = panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! ("
                       ++ show (length args) ++ ")"
 
-    (CmmPrim (MO_S_QuotRem  width) _, _) -> divOp1 platform True  width dest_regs args
-    (CmmPrim (MO_U_QuotRem  width) _, _) -> divOp1 platform False width dest_regs args
-    (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 platform False width dest_regs args
-    (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
+    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args
+    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args
+    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args
+    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->
         case args of
-        [CmmHinted arg_x _, CmmHinted arg_y _] ->
+        [arg_x, arg_y] ->
             do hCode <- getAnyReg (CmmLit (CmmInt 0 width))
                lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y])
                let size = intSize width
@@ -1709,9 +1723,9 @@ genCCall32 target dest_regs args = do
                           ADC size (OpImm (ImmInteger 0)) (OpReg reg_h)
                return code
         _ -> panic "genCCall32: Wrong number of arguments/results for add2"
-    (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
+    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->
         case args of
-        [CmmHinted arg_x _, CmmHinted arg_y _] ->
+        [arg_x, arg_y] ->
             do (y_reg, y_code) <- getRegOrMem arg_y
                x_code <- getAnyReg arg_x
                let size = intSize width
@@ -1725,22 +1739,17 @@ genCCall32 target dest_regs args = do
                return code
         _ -> panic "genCCall32: Wrong number of arguments/results for add2"
 
-    (CmmPrim _ (Just stmts), _) ->
-        stmtsToInstrs stmts
-
     _ -> genCCall32' dflags target dest_regs args
 
-  where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _]
+  where divOp1 platform signed width results [arg_x, arg_y]
             = divOp platform signed width results Nothing arg_x arg_y
         divOp1 _ _ _ _ _
             = panic "genCCall32: Wrong number of arguments for divOp1"
-        divOp2 platform signed width results [CmmHinted arg_x_high _,
-                                              CmmHinted arg_x_low _,
-                                              CmmHinted arg_y _]
+        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]
             = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y
         divOp2 _ _ _ _ _
             = panic "genCCall64: Wrong number of arguments for divOp2"
-        divOp platform signed width [CmmHinted res_q _, CmmHinted res_r _]
+        divOp platform signed width [res_q, res_r]
               m_arg_x_high arg_x_low arg_y
             = do let size = intSize width
                      reg_q = getRegisterReg platform True (CmmLocal res_q)
@@ -1766,16 +1775,16 @@ genCCall32 target dest_regs args = do
             = panic "genCCall32: Wrong number of results for divOp"
 
 genCCall32' :: DynFlags
-            -> CmmCallTarget            -- function to call
-            -> [HintedCmmFormal]        -- where to put the result
-            -> [HintedCmmActual]        -- arguments (of mixed type)
+            -> ForeignTarget            -- function to call
+            -> [CmmFormal]        -- where to put the result
+            -> [CmmActual]        -- arguments (of mixed type)
             -> NatM InstrBlock
 genCCall32' dflags target dest_regs args = do
         let
             -- Align stack to 16n for calls, assuming a starting stack
             -- alignment of 16n - word_size on procedure entry. Which we
-            -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]
-            sizes               = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args)
+            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
+            sizes               = map (arg_size . cmmExprType dflags) (reverse args)
             raw_arg_size        = sum sizes + wORD_SIZE dflags
             arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size
             tot_arg_size        = raw_arg_size + arg_pad_size - wORD_SIZE dflags
@@ -1790,16 +1799,16 @@ genCCall32' dflags target dest_regs args = do
         -- deal with static vs dynamic call targets
         (callinsns,cconv) <-
           case target of
-            CmmCallee (CmmLit (CmmLabel lbl)) conv
+            ForeignTarget (CmmLit (CmmLabel lbl)) conv
                -> -- ToDo: stdcall arg sizes
                   return (unitOL (CALL (Left fn_imm) []), conv)
                where fn_imm = ImmCLbl lbl
-            CmmCallee expr conv
+            ForeignTarget expr conv
                -> do { (dyn_r, dyn_c) <- getSomeReg expr
                      ; ASSERT( isWord32 (cmmExprType dflags expr) )
                        return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
-            CmmPrim _ _
-                -> panic $ "genCCall: Can't handle CmmPrim call type here, error "
+            PrimTarget _
+                -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
                             ++ "probably because too many return values."
 
         let push_code
@@ -1815,8 +1824,9 @@ genCCall32' dflags target dest_regs args = do
               --
               -- We have to pop any stack padding we added
               -- even if we are doing stdcall, though (#5052)
-            pop_size | cconv /= StdCallConv = tot_arg_size
-                     | otherwise = arg_pad_size
+            pop_size
+               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size
+               | otherwise = tot_arg_size
 
             call = callinsns `appOL`
                    toOL (
@@ -1833,7 +1843,7 @@ genCCall32' dflags target dest_regs args = do
         let
             -- assign the results, if necessary
             assign_code []     = nilOL
-            assign_code [CmmHinted dest _hint]
+            assign_code [dest]
               | isFloatType ty =
                  if use_sse2
                     then let tmp_amode = AddrBaseIndex (EABaseReg esp)
@@ -1869,10 +1879,10 @@ genCCall32' dflags target dest_regs args = do
         roundTo a x | x `mod` a == 0 = x
                     | otherwise = x + a - (x `mod` a)
 
-        push_arg :: Bool -> HintedCmmActual {-current argument-}
+        push_arg :: Bool -> CmmActual {-current argument-}
                         -> NatM InstrBlock  -- code
 
-        push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86
+        push_arg use_sse2 arg -- we don't need the hints on x86
           | isWord64 arg_ty = do
             ChildCode64 code r_lo <- iselExpr64 arg
             delta <- getDeltaNat
@@ -1915,29 +1925,29 @@ genCCall32' dflags target dest_regs args = do
              arg_ty = cmmExprType dflags arg
              size = arg_size arg_ty -- Byte size
 
-genCCall64 :: CmmCallTarget            -- function to call
-           -> [HintedCmmFormal]        -- where to put the result
-           -> [HintedCmmActual]        -- arguments (of mixed type)
+genCCall64 :: ForeignTarget            -- function to call
+           -> [CmmFormal]        -- where to put the result
+           -> [CmmActual]        -- arguments (of mixed type)
            -> NatM InstrBlock
 genCCall64 target dest_regs args = do
   dflags <- getDynFlags
   let platform = targetPlatform dflags
   case (target, dest_regs) of
 
-    (CmmPrim op _, []) ->
+    (PrimTarget op, []) ->
         -- void return type prim op
         outOfLineCmmOp op Nothing args
 
-    (CmmPrim op _, [res]) ->
+    (PrimTarget op, [res]) ->
         -- we only cope with a single result for foreign calls
         outOfLineCmmOp op (Just res) args
 
-    (CmmPrim (MO_S_QuotRem  width) _, _) -> divOp1 platform True  width dest_regs args
-    (CmmPrim (MO_U_QuotRem  width) _, _) -> divOp1 platform False width dest_regs args
-    (CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 platform False width dest_regs args
-    (CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
+    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args
+    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args
+    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args
+    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->
         case args of
-        [CmmHinted arg_x _, CmmHinted arg_y _] ->
+        [arg_x, arg_y] ->
             do hCode <- getAnyReg (CmmLit (CmmInt 0 width))
                lCode <- getAnyReg (CmmMachOp (MO_Add width) [arg_x, arg_y])
                let size = intSize width
@@ -1948,9 +1958,9 @@ genCCall64 target dest_regs args = do
                           ADC size (OpImm (ImmInteger 0)) (OpReg reg_h)
                return code
         _ -> panic "genCCall64: Wrong number of arguments/results for add2"
-    (CmmPrim (MO_U_Mul2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
+    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->
         case args of
-        [CmmHinted arg_x _, CmmHinted arg_y _] ->
+        [arg_x, arg_y] ->
             do (y_reg, y_code) <- getRegOrMem arg_y
                x_code <- getAnyReg arg_x
                let size = intSize width
@@ -1964,24 +1974,19 @@ genCCall64 target dest_regs args = do
                return code
         _ -> panic "genCCall64: Wrong number of arguments/results for add2"
 
-    (CmmPrim _ (Just stmts), _) ->
-        stmtsToInstrs stmts
-
     _ ->
         do dflags <- getDynFlags
            genCCall64' dflags target dest_regs args
 
-  where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _]
+  where divOp1 platform signed width results [arg_x, arg_y]
             = divOp platform signed width results Nothing arg_x arg_y
         divOp1 _ _ _ _ _
             = panic "genCCall64: Wrong number of arguments for divOp1"
-        divOp2 platform signed width results [CmmHinted arg_x_high _,
-                                              CmmHinted arg_x_low _,
-                                              CmmHinted arg_y _]
+        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]
             = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y
         divOp2 _ _ _ _ _
             = panic "genCCall64: Wrong number of arguments for divOp2"
-        divOp platform signed width [CmmHinted res_q _, CmmHinted res_r _]
+        divOp platform signed width [res_q, res_r]
               m_arg_x_high arg_x_low arg_y
             = do let size = intSize width
                      reg_q = getRegisterReg platform True (CmmLocal res_q)
@@ -2005,9 +2010,9 @@ genCCall64 target dest_regs args = do
             = panic "genCCall64: Wrong number of results for divOp"
 
 genCCall64' :: DynFlags
-            -> CmmCallTarget            -- function to call
-            -> [HintedCmmFormal]        -- where to put the result
-            -> [HintedCmmActual]        -- arguments (of mixed type)
+            -> ForeignTarget            -- function to call
+            -> [CmmFormal]        -- where to put the result
+            -> [CmmActual]        -- arguments (of mixed type)
             -> NatM InstrBlock
 genCCall64' dflags target dest_regs args = do
     -- load up the register arguments
@@ -2057,15 +2062,15 @@ genCCall64' dflags target dest_regs args = do
     -- deal with static vs dynamic call targets
     (callinsns,_cconv) <-
       case target of
-        CmmCallee (CmmLit (CmmLabel lbl)) conv
+        ForeignTarget (CmmLit (CmmLabel lbl)) conv
            -> -- ToDo: stdcall arg sizes
               return (unitOL (CALL (Left fn_imm) arg_regs), conv)
            where fn_imm = ImmCLbl lbl
-        CmmCallee expr conv
+        ForeignTarget expr conv
            -> do (dyn_r, dyn_c) <- getSomeReg expr
                  return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
-        CmmPrim _ _
-            -> panic $ "genCCall: Can't handle CmmPrim call type here, error "
+        PrimTarget _
+            -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
                         ++ "probably because too many return values."
 
     let
@@ -2094,7 +2099,7 @@ genCCall64' dflags target dest_regs args = do
     let
         -- assign the results, if necessary
         assign_code []     = nilOL
-        assign_code [CmmHinted dest _hint] =
+        assign_code [dest] =
           case typeWidth rep of
                 W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest))
                 W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest))
@@ -2115,16 +2120,16 @@ genCCall64' dflags target dest_regs args = do
   where platform = targetPlatform dflags
         arg_size = 8 -- always, at the mo
 
-        load_args :: [CmmHinted CmmExpr]
+        load_args :: [CmmExpr]
                   -> [Reg]                  -- int regs avail for args
                   -> [Reg]                  -- FP regs avail for args
                   -> InstrBlock
-                  -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock)
+                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock)
         load_args args [] [] code     =  return (args, [], [], code)
             -- no more regs to use
         load_args [] aregs fregs code =  return ([], aregs, fregs, code)
             -- no more args to push
-        load_args ((CmmHinted arg hint) : rest) aregs fregs code
+        load_args (arg : rest) aregs fregs code
             | isFloatType arg_rep =
             case fregs of
               [] -> push_this_arg
@@ -2142,21 +2147,21 @@ genCCall64' dflags target dest_regs args = do
 
               push_this_arg = do
                 (args',ars,frs,code') <- load_args rest aregs fregs code
-                return ((CmmHinted arg hint):args', ars, frs, code')
+                return (arg:args', ars, frs, code')
 
-        load_args_win :: [CmmHinted CmmExpr]
+        load_args_win :: [CmmExpr]
                       -> [Reg]        -- used int regs
                       -> [Reg]        -- used FP regs
                       -> [(Reg, Reg)] -- (int, FP) regs avail for args
                       -> InstrBlock
-                      -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock)
+                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock)
         load_args_win args usedInt usedFP [] code
             = return (args, usedInt, usedFP, code)
             -- no more regs to use
         load_args_win [] usedInt usedFP _ code
             = return ([], usedInt, usedFP, code)
             -- no more args to push
-        load_args_win ((CmmHinted arg _) : rest) usedInt usedFP
+        load_args_win (arg : rest) usedInt usedFP
                       ((ireg, freg) : regs) code
             | isFloatType arg_rep = do
                  arg_code <- getAnyReg arg
@@ -2175,7 +2180,7 @@ genCCall64' dflags target dest_regs args = do
               arg_rep = cmmExprType dflags arg
 
         push_args [] code = return code
-        push_args ((CmmHinted arg _):rest) code
+        push_args (arg:rest) code
            | isFloatType arg_rep = do
              (arg_reg, arg_code) <- getSomeReg arg
              delta <- getDeltaNat
@@ -2215,14 +2220,15 @@ genCCall64' dflags target dest_regs args = do
 maxInlineSizeThreshold :: Integer
 maxInlineSizeThreshold = 128
 
-outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock
+outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrBlock
 outOfLineCmmOp mop res args
   = do
       dflags <- getDynFlags
       targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
-      let target = CmmCallee targetExpr CCallConv
+      let target = ForeignTarget targetExpr
+                           (ForeignConvention CCallConv [] [] CmmMayReturn)
 
-      stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmMayReturn)
+      stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args')
   where
         -- Assume we can call these functions directly, and that they're not in a dynamic library.
         -- TODO: Why is this ok? Under linux this code will be in libm.so
@@ -2282,7 +2288,7 @@ outOfLineCmmOp mop res args
               MO_WriteBarrier  -> unsupported
               MO_Touch         -> unsupported
         unsupported = panic ("outOfLineCmmOp: " ++ show mop
-                          ++ "not supported here")
+                          ++ " not supported here")
 
 -- -----------------------------------------------------------------------------
 -- Generating a table-branch
index d089fc3..7d7e85c 100644 (file)
@@ -25,7 +25,7 @@ import TargetReg
 
 import BlockId
 import CodeGen.Platform
-import OldCmm
+import Cmm
 import FastString
 import FastBool
 import Outputable
index 76715f1..75d18a1 100644 (file)
@@ -35,7 +35,7 @@ import PprBase
 import BlockId
 import BasicTypes       (Alignment)
 import DynFlags
-import OldCmm
+import Cmm              hiding (topInfoTable)
 import CLabel
 import Unique           ( pprUnique, Uniquable(..) )
 import Platform
index 6b2fe16..bd60fb0 100644 (file)
@@ -51,7 +51,7 @@ import CodeGen.Platform
 import Reg
 import RegClass
 
-import OldCmm
+import Cmm
 import CmmCallConv
 import CLabel           ( CLabel )
 import DynFlags
index 88fbb3a..1573562 100644 (file)
@@ -755,19 +755,61 @@ See also Note [Implicit TyThings] in HscTypes
 %*                                                                      *
 %************************************************************************
 
-A PrimRep is somewhat similar to a CgRep (see codeGen/SMRep) and a
-MachRep (see cmm/CmmExpr), although each of these types has a distinct
-and clearly defined purpose:
-
-  - A PrimRep is a CgRep + information about signedness + information
-    about primitive pointers (AddrRep).  Signedness and primitive
-    pointers are required when passing a primitive type to a foreign
-    function, but aren't needed for call/return conventions of Haskell
-    functions.
-
-  - A MachRep is a basic machine type (non-void, doesn't contain
-    information on pointerhood or signedness, but contains some
-    reps that don't have corresponding Haskell types).
+Note [rep swamp]
+
+GHC has a rich selection of types that represent "primitive types" of
+one kind or another.  Each of them makes a different set of
+distinctions, and mostly the differences are for good reasons,
+although it's probably true that we could merge some of these.
+
+Roughly in order of "includes more information":
+
+ - A Width (cmm/CmmType) is simply a binary value with the specified
+   number of bits.  It may represent a signed or unsigned integer, a
+   floating-point value, or an address.
+
+    data Width = W8 | W16 | W32 | W64 | W80 | W128
+
+ - Size, which is used in the native code generator, is Width +
+   floating point information.
+
+   data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80
+
+   it is necessary because e.g. the instruction to move a 64-bit float
+   on x86 (movsd) is different from the instruction to move a 64-bit
+   integer (movq), so the mov instruction is parameterised by Size.
+
+ - CmmType wraps Width with more information: GC ptr, float, or
+   other value.
+
+    data CmmType = CmmType CmmCat Width
+    
+    data CmmCat     -- "Category" (not exported)
+       = GcPtrCat   -- GC pointer
+       | BitsCat    -- Non-pointer
+       | FloatCat   -- Float
+
+   It is important to have GcPtr information in Cmm, since we generate
+   info tables containing pointerhood for the GC from this.  As for
+   why we have float (and not signed/unsigned) here, see Note [Signed
+   vs unsigned].
+
+ - ArgRep makes only the distinctions necessary for the call and
+   return conventions of the STG machine.  It is essentially CmmType
+   + void.
+
+ - PrimRep makes a few more distinctions than ArgRep: it divides
+   non-GC-pointers into signed/unsigned and addresses, information
+   that is necessary for passing these values to foreign functions.
+
+There's another tension here: whether the type encodes its size in
+bytes, or whether its size depends on the machine word size.  Width
+and CmmType have the size built-in, whereas ArgRep and PrimRep do not.
+
+This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags.
+
+On the other hand, CmmType includes some "nonsense" values, such as
+CmmType GcPtrCat W32 on a 64-bit machine.
 
 \begin{code}
 -- | A 'PrimRep' is an abstraction of a type.  It contains information that