Merge remote-tracking branch 'origin/master' into newcg
authorSimon Marlow <marlowsd@gmail.com>
Mon, 13 Feb 2012 21:19:21 +0000 (21:19 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 13 Feb 2012 21:19:21 +0000 (21:19 +0000)
Conflicts:
compiler/cmm/CmmLint.hs
compiler/cmm/OldCmm.hs
compiler/codeGen/CgMonad.lhs
compiler/main/CodeOutput.lhs

17 files changed:
1  2 
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmParse.y
compiler/cmm/OldCmm.hs
compiler/cmm/OldPprCmm.hs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgMonad.lhs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/ghc.cabal.in
compiler/ghc.mk
compiler/main/CodeOutput.lhs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/utils/Outputable.lhs

Simple merge
@@@ -130,70 -119,46 +130,45 @@@ notNodeReg :: CmmExpr -> Boo
  notNodeReg (CmmReg reg) | reg == nodeReg = False
  notNodeReg _                             = True
  
 -lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint ()
 -lintCmmStmt platform labels = lint
 -    where lint (CmmNop) = return ()
 -          lint (CmmComment {}) = return ()
 -          lint stmt@(CmmAssign reg expr) = do
 -            erep <- lintCmmExpr platform expr
 -          let reg_ty = cmmRegType reg
 +lintCmmMiddle :: CmmNode O O -> CmmLint ()
 +lintCmmMiddle node = case node of
 +  CmmComment _ -> return ()
 +
 +  CmmAssign reg expr -> do
 +            erep <- lintCmmExpr expr
 +            let reg_ty = cmmRegType reg
              if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
                  then return ()
 -                else cmmLintAssignErr platform stmt erep reg_ty
 -          lint (CmmStore l r) = do
 -            _ <- lintCmmExpr platform l
 -            _ <- lintCmmExpr platform r
 +                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
 +
 +  CmmStore l r -> do
 +            _ <- lintCmmExpr l
 +            _ <- lintCmmExpr r
              return ()
 -          lint (CmmCall target _res args _) =
 -              lintTarget platform target >> mapM_ (lintCmmExpr platform . hintlessCmm) args
 -          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond platform e
 -          lint (CmmSwitch e branches) = do
 +
 +  CmmUnsafeForeignCall target _formals actuals -> do
 +            lintTarget target
 +            mapM_ lintCmmExpr actuals
 +
 +
 +lintCmmLast :: BlockSet -> CmmNode O C -> CmmLint ()
 +lintCmmLast labels node = case node of
 +  CmmBranch id -> checkTarget id
 +
 +  CmmCondBranch e t f -> do
 +            mapM_ checkTarget [t,f]
 +            _ <- lintCmmExpr e
 +            checkCond e
 +
 +  CmmSwitch e branches -> do
              mapM_ checkTarget $ catMaybes branches
 -            erep <- lintCmmExpr platform e
 +            erep <- lintCmmExpr e
              if (erep `cmmEqType_ignoring_ptrhood` bWord)
                then return ()
 -              else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <>
 +              else cmmLintErr (\platform ->
 +                               text "switch scrutinee is not a word: " <>
 +                               pprPlatform platform e <>
                                 text " :: " <> ppr erep)
-   CmmCall { cml_target = target, cml_cont = cont } -> do
-           _ <- lintCmmExpr target
-           maybe (return ()) checkTarget cont
-   CmmForeignCall tgt _ args succ _ _ -> do
-           lintTarget tgt
-           mapM_ lintCmmExpr args
-           checkTarget succ
-  where
-   checkTarget id
-      | setMember id labels = return ()
-      | otherwise = cmmLintErr (\_ -> text "Branch to nonexistent id" <+> ppr id)
 -          lint (CmmJump e _) = lintCmmExpr platform 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 :: ForeignTarget -> CmmLint ()
- lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
- lintTarget (PrimTarget {})     = return ()
 -lintTarget :: Platform -> CmmCallTarget -> CmmLint ()
 -lintTarget platform (CmmCallee e _) = lintCmmExpr platform e >> return ()
 -lintTarget _        (CmmPrim {})    = return ()
--
--
- checkCond :: CmmExpr -> CmmLint ()
- checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
- checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
- checkCond expr
-     = cmmLintErr (\platform -> hang (text "expression is not a conditional:") 2
 -checkCond :: Platform -> CmmExpr -> CmmLint ()
 -checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
 -checkCond _ (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
 -checkCond platform expr
 -    = cmmLintErr (hang (text "expression is not a conditional:") 2
                         (pprPlatform platform expr))
  
  -- -----------------------------------------------------------------------------
Simple merge
@@@ -9,26 -9,25 +9,23 @@@
  module OldCmm (
          CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl,
          ListGraph(..),
 -
 -        CmmInfo(..), CmmInfoTable(..), ClosureTypeInfo(..), UpdateFrame(..),
 -
 +        UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..),
          CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
          cmmMapGraph, cmmTopMapGraph,
          GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
          CmmStmt(..), CmmReturnInfo(..), CmmHinted(..),
          HintedCmmFormal, HintedCmmActual,
          CmmSafety(..), CmmCallTarget(..),
-         New.GenCmmDecl(..),
-         New.ForeignHint(..),
+         New.GenCmmDecl(..), New.ForeignHint(..),
          module CmmExpr,
-         Section(..),
-         ProfilingInfo(..), C_SRT(..)
-   ) where
+         Section(..), ProfilingInfo(..), C_SRT(..)
+     ) where
  
  #include "HsVersions.h"
  
@@@ -53,12 -52,19 +50,12 @@@ import ForeignCal
  --     Info Tables
  -----------------------------------------------------------------------------
  
 -data CmmInfo
 -  = CmmInfo
 -        (Maybe BlockId)     -- GC target. Nothing <=> CPS won't do stack check
 -                            -- JD: NOT USED BY NEW CODE GEN
 -        (Maybe UpdateFrame) -- Update frame
 -        CmmInfoTable        -- Info table
 -
  -- | A frame that is to be pushed before entry to the function.
  -- Used to handle 'update' frames.
- data UpdateFrame =
-     UpdateFrame
-       CmmExpr    -- Frame header.  Behaves like the target of a 'jump'.
-       [CmmExpr]  -- Frame remainder.  Behaves like the arguments of a 'jump'.
+ data UpdateFrame
+   = UpdateFrame
+         CmmExpr    -- Frame header.  Behaves like the target of a 'jump'.
+         [CmmExpr]  -- Frame remainder.  Behaves like the arguments of a 'jump'.
  
  -----------------------------------------------------------------------------
  --  Cmm, CmmDecl, CmmBasicBlock
  -- 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]
-    -- ^ 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.
  
  -- | Cmm with the info table as a data type
 -type CmmGroup = GenCmmGroup CmmStatics CmmInfo (ListGraph CmmStmt)
 -type CmmDecl = GenCmmDecl CmmStatics CmmInfo (ListGraph CmmStmt)
 +type CmmGroup = GenCmmGroup CmmStatics CmmInfoTable (ListGraph CmmStmt)
 +type CmmDecl = GenCmmDecl CmmStatics CmmInfoTable (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
Simple merge
Simple merge
@@@ -11,13 -11,12 +11,12 @@@ stuff fits into the Big Picture
  
  {-# LANGUAGE BangPatterns #-}
  module CgMonad (
-         Code,
-         FCode,
+         Code, FCode,
  
 -        initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
 -        returnFC, fixC, fixC_, checkedAbsC,
 +        initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
 +        returnFC, fixC, fixC_, checkedAbsC, 
          stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
-         newUnique, newUniqSupply, 
+         newUnique, newUniqSupply,
  
          CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
          getCgStmts', getCgStmts,
@@@ -375,33 -384,25 +384,44 @@@ instance Monad FCode wher
  {-# INLINE thenC #-}
  {-# INLINE thenFC #-}
  {-# INLINE returnFC #-}
- \end{code}
- The Abstract~C is not in the environment so as to improve strictness.
  
++<<<<<<< HEAD
 +\begin{code}
 +initC :: IO CgState
 +initC  = do { uniqs <- mkSplitUniqSupply 'c'
 +            ; return (initCgState uniqs) }
 +
 +runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
 +runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
++||||||| merged common ancestors
++\begin{code}
++initC :: DynFlags -> Module -> FCode a -> IO a
++
++initC dflags mod (FCode code)
++  = do  { uniqs <- mkSplitUniqSupply 'c'
++        ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
++              (res, _) -> return res
++        }
++=======
+ initC :: DynFlags -> Module -> FCode a -> IO a
+ initC dflags mod (FCode code) = do
+     uniqs <- mkSplitUniqSupply 'c'
+     case code (initCgInfoDown dflags mod) (initCgState uniqs) of
+         (res, _) -> return res
++>>>>>>> origin/master
  
  returnFC :: a -> FCode a
- returnFC val = FCode (\_ state -> (val, state))
- \end{code}
+ returnFC val = FCode $ \_ state -> (val, state)
  
- \begin{code}
  thenC :: Code -> FCode a -> FCode a
- thenC (FCode m) (FCode k) = 
-         FCode (\info_down state -> let (_,new_state) = m info_down state in 
-                 k info_down new_state)
+ thenC (FCode m) (FCode k) = FCode $ \info_down state ->
+     let (_,new_state) = m info_down state
+     in k info_down new_state
  
  listCs :: [Code] -> Code
- listCs [] = return ()
- listCs (fc:fcs) = do
-         fc
-         listCs fcs
-         
+ listCs []       = return ()
+ listCs (fc:fcs) = fc >> listCs fcs
  mapCs :: (a -> Code) -> [a] -> Code
  mapCs = mapM_
  
@@@ -718,29 -698,28 +717,54 @@@ forkLabelledCode :: Code -> FCode Block
  forkLabelledCode code = getCgStmts code >>= forkCgStmts
  
  emitCgStmt :: CgStmt -> Code
- emitCgStmt stmt
-   = do  { state <- getState
-         ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
-         }
+ emitCgStmt stmt = do
+     state <- getState
+     setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
  
  emitDecl :: CmmDecl -> Code
- emitDecl decl
-   = do  { state <- getState
-         ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
+ emitDecl decl = do
+     state <- getState
+     setState $ state { cgs_tops = cgs_tops state `snocOL` decl }
  
++<<<<<<< HEAD
 +emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
 +emitProc info lbl [] blocks
 +  = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
 +        ; state <- getState
 +        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
++||||||| merged common ancestors
++emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
++emitProc info lbl [] blocks
++  = do  { let proc_block = CmmProc info lbl (ListGraph blocks)
++        ; state <- getState
++        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
++=======
+ emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
+ emitProc info lbl [] blocks = do
+     let proc_block = CmmProc info lbl (ListGraph blocks)
+     state <- getState
+     setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block }
++>>>>>>> origin/master
  emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
  
  -- Emit a procedure whose body is the specified code; no info table
  emitSimpleProc :: CLabel -> Code -> Code
++<<<<<<< HEAD
 +emitSimpleProc lbl code
 +  = do  { stmts <- getCgStmts code
 +        ; blks <- cgStmtsToBlocks stmts
 +        ; emitProc CmmNonInfoTable lbl [] blks }
++||||||| merged common ancestors
++emitSimpleProc lbl code
++  = do  { stmts <- getCgStmts code
++        ; blks <- cgStmtsToBlocks stmts
++        ; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
++=======
+ emitSimpleProc lbl code = do
+     stmts <- getCgStmts code
+     blks <- cgStmtsToBlocks stmts
+     emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks
++>>>>>>> origin/master
  
  -- Get all the CmmTops (there should be no stmts)
  -- Return a single Cmm which may be split from other Cmms by
Simple merge
Simple merge
Simple merge
Simple merge
diff --cc compiler/ghc.mk
Simple merge
@@@ -18,11 -11,11 +11,11 @@@ module CodeOutput( codeOutput, outputFo
  import AsmCodeGen ( nativeCodeGen )
  import LlvmCodeGen ( llvmCodeGen )
  
- import UniqSupply     ( mkSplitUniqSupply )
+ import UniqSupply       ( mkSplitUniqSupply )
  
- import Finder         ( mkStubPaths )
+ import Finder           ( mkStubPaths )
 -import PprC             ( writeCs )
 -import CmmLint          ( cmmLint )
 +import PprC           ( writeCs )
 +import OldCmmLint       ( cmmLint )
  import Packages
  import Util
  import OldCmm           ( RawCmmGroup )
@@@ -30,13 -23,11 +23,13 @@@ import HscType
  import DynFlags
  import Config
  import SysTools
 +import Stream           (Stream)
 +import qualified Stream
  
- import ErrUtils               ( dumpIfSet_dyn, showPass, ghcExit )
+ import ErrUtils         ( dumpIfSet_dyn, showPass, ghcExit )
  import Outputable
  import Module
- import Maybes         ( firstJusts )
+ import Maybes           ( firstJusts )
  
  import Control.Exception
  import Control.Monad
@@@ -53,44 -44,37 +46,44 @@@ import System.I
  
  \begin{code}
  codeOutput :: DynFlags
-          -> Module
+            -> Module
 -           -> ModLocation
 -           -> ForeignStubs
 -           -> [PackageId]
 -           -> [RawCmmGroup]                       -- Compiled C--
 +         -> ModLocation
 +         -> ForeignStubs
 +         -> [PackageId]
 +           -> Stream IO RawCmmGroup ()                       -- Compiled C--
             -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
  
 -codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
 +codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream
    = 
 -    do  { when (dopt Opt_DoCmmLinting dflags) $ do
 +    do  {
 +        -- Lint each CmmGroup as it goes past
 +        ; let linted_cmm_stream =
 +                 if dopt Opt_DoCmmLinting dflags
 +                    then Stream.mapM do_lint cmm_stream
 +                    else cmm_stream
 +
 +              do_lint cmm = do
                  { showPass dflags "CmmLint"
 -                ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
 -                ; case firstJusts lints of
 -                        Just err -> do { printDump err
 -                                       ; ghcExit dflags 1
 -                                       }
 -                        Nothing  -> return ()
 +                ; case cmmLint (targetPlatform dflags) cmm of
 +                      Just err -> do { printDump err
 +                                     ; ghcExit dflags 1
 +                                     }
 +                      Nothing  -> return ()
 +                ; return cmm
                  }
  
 -        ; showPass dflags "CodeOutput"
 -        ; let filenm = hscOutName dflags 
 -        ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
 -        ; case hscTarget dflags of {
 +      ; showPass dflags "CodeOutput"
 +      ; let filenm = hscOutName dflags 
 +      ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
 +      ; case hscTarget dflags of {
               HscInterpreted -> return ();
 -             HscAsm         -> outputAsm dflags filenm flat_abstractC;
 -             HscC           -> outputC dflags filenm flat_abstractC pkg_deps;
 -             HscLlvm        -> outputLlvm dflags filenm flat_abstractC;
 +             HscAsm         -> outputAsm dflags filenm linted_cmm_stream;
 +             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;
 +             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;
               HscNothing     -> panic "codeOutput: HscNothing"
-         }
-       ; return stubs_exist
-       }
+           }
+         ; return stubs_exist
+         }
  
  doOutput :: String -> (Handle -> IO ()) -> IO ()
  doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
@@@ -135,9 -115,9 +128,9 @@@ outputC dflags filenm cmm_stream packag
         let pkg_names = map (display.sourcePackageId) pkg_configs
  
         doOutput filenm $ \ h -> do
-         hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
+           hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
 -          hPutStr h cc_injects
 -          writeCs dflags h flat_absC
 +        hPutStr h cc_injects
 +          writeCs dflags h rawcmms
  \end{code}
  
  
Simple merge
Simple merge
Simple merge
Simple merge