X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fcmm%2FCmmParse.y;h=b3f68a9b1ed9da2fad1d1be3ffc1202a80a7ef92;hb=23e5985c3db852981d527d10d6a6271688049790;hp=05ec274d8301497bf2481548da319e6aa9fa2ded;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 05ec274..b3f68a9 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -46,8 +46,9 @@ import Panic
 import Constants
 import Outputable
 
-import Control.Monad	( when )
+import Control.Monad
 import Data.Char	( ord )
+import System.Exit
 
 #include "HsVersions.h"
 }
@@ -223,18 +224,14 @@ info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
 	
 	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, tag, closure type, description, type
-		{ stdInfo $3 $5 $7 $9 $11 $13 $15 }
+		{ conInfo $3 $5 $7 $9 $11 $13 $15 }
 	
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- 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 () }
@@ -424,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
 
@@ -471,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:
@@ -528,9 +525,9 @@ machOps = listToUFM $
 	( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
 	( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
 	( "f2i8",     flip MO_S_Conv I8 ),
-	( "f2i16",    flip MO_S_Conv I8 ),
-	( "f2i32",    flip MO_S_Conv I8 ),
-	( "f2i64",    flip MO_S_Conv I8 ),
+	( "f2i16",    flip MO_S_Conv I16 ),
+	( "f2i32",    flip MO_S_Conv I32 ),
+	( "f2i64",    flip MO_S_Conv I64 ),
 	( "i2f32",    flip MO_S_Conv F32 ),
 	( "i2f64",    flip MO_S_Conv F64 )
 	]
@@ -610,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)])
@@ -707,28 +705,38 @@ 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 =
   basicInfo name (packHalfWordsCLit ptrs nptrs) 
 	srt_bitmap cl_type desc_str ty_str
 
+conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
+  (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs) 
+                	srt_bitmap cl_type desc_str ty_str
+  desc_lit <- code $ mkStringCLit desc_str
+  let desc_field = makeRelativeRefTo lbl desc_lit
+  return (lbl, info1, [desc_field])
+
 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
+  let info_lbl = mkRtsInfoLabelFS name
   lit1 <- if opt_SccProfilingOn 
-		   then code $ mkStringCLit desc_str
+		   then code $ do lit <- mkStringCLit desc_str
+                                  return (makeRelativeRefTo info_lbl lit)
 		   else return (mkIntCLit 0)
   lit2 <- if opt_SccProfilingOn 
-		   then code $ mkStringCLit ty_str
+		   then code $ do lit <- mkStringCLit ty_str
+                                  return (makeRelativeRefTo info_lbl lit)
 		   else return (mkIntCLit 0)
   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
 			(fromIntegral srt_bitmap)
 			layout
-  return (mkRtsInfoLabelFS name, info1, [])
+  return (info_lbl, info1, [])
 
 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
@@ -917,9 +925,12 @@ parseCmmFile dflags 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
+    POk pst code -> do
 	cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
-	dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+	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"