X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fcmm%2FCmmParse.y;h=6048c44d12711e05455cff04d43511499745cb1f;hb=6c6d815b809da869ce2d98e4edc1f6350876a898;hp=a1cbbf51ed9bd824509e036ae5795a05c5d261c8;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index a1cbbf5..6048c44 100644
--- 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,38 +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 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"
 }
@@ -103,6 +104,7 @@ import Data.Char	( ord )
 	'jump'		{ L _ (CmmT_jump) }
 	'foreign'	{ L _ (CmmT_foreign) }
 	'prim'		{ L _ (CmmT_prim) }
+	'return'	{ L _ (CmmT_return) }
 	'import'	{ L _ (CmmT_import) }
 	'switch'	{ L _ (CmmT_switch) }
 	'case'		{ L _ (CmmT_case) }
@@ -197,20 +199,23 @@ lits	:: { [ExtFCode CmmExpr] }
 	| ',' expr lits		{ $2 : $3 }
 
 cmmproc :: { ExtCode }
-	: info '{' body '}'
-		{ do  (info_lbl, info1, info2) <- $1;
-		      stmts <- getCgStmtsEC (loopDecls $3)
-		      blks <- code (cgStmtsToBlocks stmts)
-		      code (emitInfoTableAndCode info_lbl info1 info2 [] blks) }
+	: info maybe_formals '{' body '}'
+		{ do (info_lbl, info1, info2) <- $1;
+		     formals <- sequence $2;
+		     stmts <- getCgStmtsEC (loopDecls $4)
+		     blks <- code (cgStmtsToBlocks stmts)
+		     code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
 
-	| info ';'
+	| info maybe_formals ';'
 		{ do (info_lbl, info1, info2) <- $1;
-		     code (emitInfoTableAndCode info_lbl info1 info2 [] []) }
+		     formals <- sequence $2;
+		     code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
 
-	| NAME '{' body '}'
-		{ do stmts <- getCgStmtsEC (loopDecls $3);
-		     blks <- code (cgStmtsToBlocks stmts)
-		     code (emitProc [] (mkRtsCodeLabelFS $1) [] blks) }
+	| NAME maybe_formals '{' body '}'
+		{ do formals <- sequence $2;
+		     stmts <- getCgStmtsEC (loopDecls $4);
+		     blks <- code (cgStmtsToBlocks stmts);
+		     code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
 
 info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
@@ -223,18 +228,15 @@ 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 ')'
+		-- size, live bits, closure type
+		{ retInfo $3 $5 $7 $9 }
 
 body	:: { ExtCode }
 	: {- empty -}			{ return () }
@@ -256,24 +258,16 @@ stmt	:: { ExtCode }
 	| NAME ':'
 		{ do l <- newLabel $1; code (labelC l) }
 
-	| lreg '=' expr ';'			
-		{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
+-- HACK: this should just be lregs but that causes a shift/reduce conflict
+-- with foreign calls
+--	| hint_lregs '=' expr ';'
+--		{ do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
 	| type '[' expr ']' '=' expr ';'
 		{ doStore $1 $3 $6 }
-	| 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-		{% foreignCall $2 [] $3 $5 $7 }
-	| lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-		{% let result = do r <- $1; return (r,NoHint) in
-		   foreignCall $4 [result] $5 $7 $9 }
-	| 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-		{% primCall [] $3 $5 $7 }
-	| lreg '=' 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-		{% let result = do r <- $1; return (r,NoHint) in
-		   primCall [result] $5 $7 $9 }
-	| STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-		{% do h <- parseHint $1;
-		      let result = do r <- $2; return (r,h) in
-		      foreignCall $5 [result] $6 $8 $10 }
+	| maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+		{% foreignCall $3 $1 $4 $6 $8 }
+	| maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
+		{% primCall $1 $4 $6 $8 }
 	-- stmt-level macros, stealing syntax from ordinary C-- function calls.
 	-- Perhaps we ought to use the %%-form?
 	| NAME '(' exprs0 ')' ';'
@@ -282,8 +276,10 @@ stmt	:: { ExtCode }
 		{ doSwitch $2 $3 $5 $6 }
 	| 'goto' NAME ';'
 		{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
-	| 'jump' expr {-maybe_actuals-} ';'
-		{ do e <- $2; stmtEC (CmmJump e []) }
+	| 'jump' expr maybe_actuals ';'
+		{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
+        | 'return' maybe_actuals ';'
+		{ do e <- sequence $2; stmtEC (CmmReturn e) }
 	| 'if' bool_expr '{' body '}' else 	
 		{ ifThenElse $2 $4 $6 }
 
@@ -375,6 +371,10 @@ maybe_ty :: { MachRep }
 	: {- empty -}			{ wordRep }
 	| '::' type			{ $2 }
 
+maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
+	: {- empty -}		{ [] }
+	| '(' hint_exprs0 ')'	{ $2 }
+
 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
 	: {- empty -}			{ [] }
 	| hint_exprs			{ $1 }
@@ -401,6 +401,21 @@ reg	:: { ExtFCode CmmExpr }
 	: NAME			{ lookupName $1 }
 	| GLOBALREG		{ return (CmmReg (CmmGlobal $1)) }
 
+maybe_results :: { [ExtFCode (CmmReg, MachHint)] }
+	: {- empty -}		{ [] }
+	| hint_lregs '='	{ $1 }
+
+hint_lregs :: { [ExtFCode (CmmReg, MachHint)] }
+	: hint_lreg ','			{ [$1] }
+	| hint_lreg			{ [$1] }
+	| hint_lreg ',' hint_lregs	{ $1 : $3 }
+
+hint_lreg :: { ExtFCode (CmmReg, MachHint) }
+	: lreg				{ do e <- $1; return (e, inferHint (CmmReg e)) }
+	| STRING lreg			{% do h <- parseHint $1;
+					      return $ do
+						e <- $2; return (e,h) }
+
 lreg	:: { ExtFCode CmmReg }
 	: NAME			{ do e <- lookupName $1;
 				     return $
@@ -409,6 +424,24 @@ lreg	:: { ExtFCode CmmReg }
 					other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 	| GLOBALREG		{ return (CmmGlobal $1) }
 
+maybe_formals :: { [ExtFCode LocalReg] }
+	: {- empty -}		{ [] }
+	| '(' formals0 ')'	{ $2 }
+
+formals0 :: { [ExtFCode LocalReg] }
+	: {- empty -}		{ [] }
+	| formals		{ $1 }
+
+formals :: { [ExtFCode LocalReg] }
+	: formal ','		{ [$1] }
+	| formal		{ [$1] }
+	| formal ',' formals	{ $1 : $3 }
+
+formal :: { ExtFCode LocalReg }
+	: type NAME		{ newLocal defaultKind $1 $2 }
+	| STRING type NAME	{% do k <- parseKind $1;
+				     return $ newLocal k $2 $3 }
+
 type	:: { MachRep }
 	: 'bits8'		{ I8 }
 	| typenot8		{ $1 }
@@ -424,6 +457,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 +505,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 +561,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 +643,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 +741,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-}
@@ -752,15 +796,17 @@ foreignCall
 	-> ExtFCode CmmExpr
 	-> [ExtFCode (CmmExpr,MachHint)]
 	-> Maybe [GlobalReg] -> P ExtCode
-foreignCall "C" results_code expr_code args_code vols
-  = return $ do
-	results <- sequence results_code
-	expr <- expr_code
-	args <- sequence args_code
-        code (emitForeignCall' PlayRisky results 
-                 (CmmForeignCall expr CCallConv) args vols)
-foreignCall conv _ _ _ _
-  = fail ("unknown calling convention: " ++ conv)
+foreignCall conv_string results_code expr_code args_code vols
+  = do  convention <- case conv_string of
+          "C" -> return CCallConv
+          "C--" -> return CmmCallConv
+          _ -> fail ("unknown calling convention: " ++ conv_string)
+	return $ do
+	  results <- sequence results_code
+	  expr <- expr_code
+	  args <- sequence args_code
+          code (emitForeignCall' PlayRisky results 
+                 (CmmForeignCall expr convention) args vols) where
 
 primCall
 	:: [ExtFCode (CmmReg,MachHint)]
@@ -917,9 +963,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"