Re-working of the breakpoint support

[ghc-hetmet.git] / compiler / cmm / CmmParse.y

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 5908314..bd35072 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1,6 +1,6 @@
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow, 2004
+-- (c) The University of Glasgow, 2004-2006
 --
 -- Parser for concrete Cmm.
 --
@@ -16,39 +16,39 @@ import CgProf
 import CgTicky
 import CgInfoTbls
 import CgForeignCall
-import CgTailCall      ( pushUnboxedTuple )
-import CgStackery      ( emitPushUpdateFrame )
-import ClosureInfo     ( C_SRT(..) )
-import CgCallConv      ( smallLiveness )
-import CgClosure       ( emitBlackHoleCode )
-import CostCentre      ( dontCareCCS )
+import CgTailCall
+import CgStackery
+import ClosureInfo
+import CgCallConv
+import CgClosure
+import CostCentre
 
 import Cmm
 import PprCmm
-import CmmUtils                ( mkIntCLit )
+import CmmUtils
 import CmmLex
 import CLabel
 import MachOp
-import SMRep           ( fixedHdrSize, CgRep(..) )
+import SMRep
 import Lexer
 
-import ForeignCall     ( CCallConv(..), Safety(..) )
-import Literal         ( mkMachInt )
+import ForeignCall
+import Literal
 import Unique
 import UniqFM
 import SrcLoc
-import DynFlags                ( DynFlags, DynFlag(..) )
-import Packages                ( HomeModules )
-import StaticFlags     ( opt_SccProfilingOn )
-import ErrUtils                ( printError, dumpIfSet_dyn, showPass )
-import StringBuffer    ( hGetStringBuffer )
+import DynFlags
+import StaticFlags
+import ErrUtils
+import StringBuffer
 import FastString
-import Panic           ( panic )
-import Constants       ( wORD_SIZE )
+import Panic
+import Constants
 import Outputable
 
-import Monad           ( when )
+import Control.Monad
 import Data.Char       ( ord )
+import System.Exit
 
 #include "HsVersions.h"
 }
@@ -230,12 +230,8 @@ info       :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
                -- selector, closure type, description, type
                { basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
 
-       | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
-               { retInfo $3 $5 $7 $9 $10 }
-
-maybe_vec :: { [CmmLit] }
-       : {- empty -}                   { [] }
-       | ',' NAME maybe_vec            { CmmLabel (mkRtsCodeLabelFS $2) : $3 }
+       | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT ')'
+               { retInfo $3 $5 $7 $9 }
 
 body   :: { ExtCode }
        : {- empty -}                   { return () }
@@ -425,6 +421,7 @@ section :: String -> Section
 section "text"  = Text
 section "data"          = Data
 section "rodata" = ReadOnlyData
+section "relrodata" = RelocatableReadOnlyData
 section "bss"   = UninitialisedData
 section s       = OtherSection s
 
@@ -472,8 +469,7 @@ exprMacros = listToUFM [
   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
-  ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x ),
-  ( FSLIT("RET_VEC"),      \ [info, conZ] -> retVec info conZ )
+  ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x )
   ]
 
 -- we understand a subset of C-- primitives:
@@ -611,6 +607,7 @@ stmtMacros = listToUFM [
   ( FSLIT("RET_NN"),   \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
   ( FSLIT("RET_NP"),   \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
   ( FSLIT("RET_PPP"),  \[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
+  ( FSLIT("RET_NPP"),  \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
   ( FSLIT("RET_NNP"),  \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
   ( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
   ( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
@@ -708,11 +705,11 @@ forkLabelledCodeEC ec = do
   stmts <- getCgStmtsEC ec
   code (forkCgStmts stmts)
 
-retInfo name size live_bits cl_type vector = do
+retInfo name size live_bits cl_type = do
   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
       info_lbl = mkRtsRetInfoLabelFS name
       (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
-                               (fromIntegral cl_type) vector
+                               (fromIntegral cl_type)
   return (info_lbl, info1, info2)
 
 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
@@ -907,8 +904,8 @@ initEnv = listToUFM [
     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
   ]
 
-parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags hmods filename = do
+parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags filename = do
   showPass dflags "ParseCmm"
   buf <- hGetStringBuffer filename
   let
@@ -918,9 +915,12 @@ parseCmmFile dflags hmods filename = do
                -- in there we don't want.
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing
-    POk _ code -> do
-       cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
-       dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+    POk pst code -> do
+       cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
+       let ms = getMessages pst
+       printErrorsAndWarnings dflags ms
+        when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
        return (Just cmm)
   where
        no_module = panic "parseCmmFile: no module"