X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=70cd7c4c5bb3a8bc6909bdab3e955bde87c215c7;hb=d76b6a05ab36066e8aeb67d58e25992d1ef83a8a;hp=c2dd22f8dc3e6784158a4202704c0b7cdce6681f;hpb=1c5499d4d5d506ce0cc971e98c09bfbf7bc290a1;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index c2dd22f..70cd7c4 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -7,6 +7,13 @@
 -----------------------------------------------------------------------------
 
 {
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CmmParse ( parseCmmFile ) where
 
 import CgMonad
@@ -47,6 +54,7 @@ import Constants
 import Outputable
 
 import Control.Monad
+import Data.Array
 import Data.Char	( ord )
 import System.Exit
 
@@ -103,8 +111,10 @@ import System.Exit
 	'if'		{ L _ (CmmT_if) }
 	'jump'		{ L _ (CmmT_jump) }
 	'foreign'	{ L _ (CmmT_foreign) }
+	'never'		{ L _ (CmmT_never) }
 	'prim'		{ L _ (CmmT_prim) }
 	'return'	{ L _ (CmmT_return) }
+	'returns'	{ L _ (CmmT_returns) }
 	'import'	{ L _ (CmmT_import) }
 	'switch'	{ L _ (CmmT_switch) }
 	'case'		{ L _ (CmmT_case) }
@@ -200,31 +210,31 @@ lits	:: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
-	: info maybe_formals maybe_frame maybe_gc_block '{' body '}'
-		{ do ((entry_ret_label, info, live, formals, frame, gc_block), stmts) <-
+	: info maybe_formals_without_kinds maybe_gc_block maybe_frame '{' body '}'
+		{ do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <-
 		       getCgStmtsEC' $ loopDecls $ do {
 		         (entry_ret_label, info, live) <- $1;
 		         formals <- sequence $2;
-		         frame <- $3;
-		         gc_block <- $4;
+		         gc_block <- $3;
+		         frame <- $4;
 		         $6;
-		         return (entry_ret_label, info, live, formals, frame, gc_block) }
+		         return (entry_ret_label, info, live, formals, gc_block, frame) }
 		     blks <- code (cgStmtsToBlocks stmts)
 		     code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
 
-	| info maybe_formals ';'
+	| info maybe_formals_without_kinds ';'
 		{ do (entry_ret_label, info, live) <- $1;
 		     formals <- sequence $2;
 		     code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
 
-	| NAME maybe_formals maybe_frame maybe_gc_block '{' body '}'
-		{ do ((formals, frame, gc_block), stmts) <-
+	| NAME maybe_formals_without_kinds maybe_gc_block maybe_frame '{' body '}'
+		{ do ((formals, gc_block, frame), stmts) <-
 			getCgStmtsEC' $ loopDecls $ do {
 		          formals <- sequence $2;
-			  frame <- $3;
-		          gc_block <- $4;
+		          gc_block <- $3;
+			  frame <- $4;
 		          $6;
-		          return (formals, frame, gc_block) }
+		          return (formals, gc_block, frame) }
                      blks <- code (cgStmtsToBlocks stmts)
 		     code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
 
@@ -248,6 +258,19 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 			[]) }
 		-- we leave most of the fields zero here.  This is only used
 		-- to generate the BCO info table in the RTS at the moment.
+
+	-- A variant with a non-zero arity (needed to write Main_main in Cmm)
+	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
+		-- ptrs, nptrs, closure type, description, type, fun type, arity
+		{ do prof <- profilingInfo $11 $13
+		     return (mkRtsEntryLabelFS $3,
+			CmmInfoTable prof (fromIntegral $9)
+				     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) (fromIntegral $17)
+				      (ArgSpec 0)
+				      zeroCLit),
+			[]) }
+		-- we leave most of the fields zero here.  This is only used
+		-- to generate the BCO info table in the RTS at the moment.
 	
 	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, tag, closure type, description, type
@@ -276,7 +299,7 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 				     (ContInfo [] NoC_SRT),
 			[]) }
 
-	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
+	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_kinds0 ')'
 		-- closure type, live regs
 		{ do live <- sequence (map (liftM Just) $7)
 		     return (mkRtsRetLabelFS $3,
@@ -291,7 +314,7 @@ body	:: { ExtCode }
 
 decl	:: { ExtCode }
 	: type names ';'		{ mapM_ (newLocal defaultKind $1) $2 }
-	| STRING type names ';'		{% do k <- parseKind $1;
+	| STRING type names ';'		{% do k <- parseGCKind $1;
 					      return $ mapM_ (newLocal k $2) $3 }
 
 	| 'import' names ';'		{ mapM_ newImport $2 }
@@ -318,9 +341,9 @@ stmt	:: { ExtCode }
 	-- we tweak the syntax to avoid the conflict.  The later
 	-- option is taken here because the other way would require
 	-- multiple levels of expanding and get unwieldy.
-	| maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' safety vols ';'
-		{% foreignCall $3 $1 $4 $6 $9 $8 }
-	| maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' safety vols ';'
+	| maybe_results 'foreign' STRING expr '(' cmm_kind_exprs0 ')' safety vols opt_never_returns ';'
+		{% foreignCall $3 $1 $4 $6 $9 $8 $10 }
+	| maybe_results 'prim' '%' NAME '(' cmm_kind_exprs0 ')' safety vols ';'
 		{% primCall $1 $4 $6 $9 $8 }
 	-- stmt-level macros, stealing syntax from ordinary C-- function calls.
 	-- Perhaps we ought to use the %%-form?
@@ -337,6 +360,10 @@ stmt	:: { ExtCode }
 	| 'if' bool_expr '{' body '}' else 	
 		{ ifThenElse $2 $4 $6 }
 
+opt_never_returns :: { CmmReturnInfo }
+        :                               { CmmMayReturn }
+        | 'never' 'returns'             { CmmNeverReturns }
+
 bool_expr :: { ExtFCode BoolExpr }
 	: bool_op			{ $1 }
 	| expr				{ do e <- $1; return (BoolTest e) }
@@ -430,23 +457,23 @@ maybe_ty :: { MachRep }
 	: {- empty -}			{ wordRep }
 	| '::' type			{ $2 }
 
-maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
+maybe_actuals :: { [ExtFCode CmmActual] }
 	: {- empty -}		{ [] }
-	| '(' hint_exprs0 ')'	{ $2 }
+	| '(' cmm_kind_exprs0 ')'	{ $2 }
 
-hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
+cmm_kind_exprs0 :: { [ExtFCode CmmActual] }
 	: {- empty -}			{ [] }
-	| hint_exprs			{ $1 }
+	| cmm_kind_exprs			{ $1 }
 
-hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
-	: hint_expr			{ [$1] }
-	| hint_expr ',' hint_exprs	{ $1 : $3 }
+cmm_kind_exprs :: { [ExtFCode CmmActual] }
+	: cmm_kind_expr			{ [$1] }
+	| cmm_kind_expr ',' cmm_kind_exprs	{ $1 : $3 }
 
-hint_expr :: { ExtFCode (CmmExpr, MachHint) }
-	: expr				{ do e <- $1; return (e, inferHint e) }
-	| expr STRING			{% do h <- parseHint $2;
+cmm_kind_expr :: { ExtFCode CmmActual }
+	: expr				{ do e <- $1; return (CmmHinted e (inferCmmKind e)) }
+	| expr STRING			{% do h <- parseCmmKind $2;
 					      return $ do
-						e <- $1; return (e,h) }
+						e <- $1; return (CmmHinted e h) }
 
 exprs0  :: { [ExtFCode CmmExpr] }
 	: {- empty -}			{ [] }
@@ -460,20 +487,20 @@ reg	:: { ExtFCode CmmExpr }
 	: NAME			{ lookupName $1 }
 	| GLOBALREG		{ return (CmmReg (CmmGlobal $1)) }
 
-maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
+maybe_results :: { [ExtFCode CmmFormal] }
 	: {- empty -}		{ [] }
-	| '(' hint_lregs ')' '='	{ $2 }
+	| '(' cmm_formals ')' '='	{ $2 }
 
-hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
-	: hint_lreg			{ [$1] }
-	| hint_lreg ','			{ [$1] }
-	| hint_lreg ',' hint_lregs	{ $1 : $3 }
+cmm_formals :: { [ExtFCode CmmFormal] }
+	: cmm_formal			{ [$1] }
+	| cmm_formal ','			{ [$1] }
+	| cmm_formal ',' cmm_formals	{ $1 : $3 }
 
-hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
-	: local_lreg			{ do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
-	| STRING local_lreg		{% do h <- parseHint $1;
+cmm_formal :: { ExtFCode CmmFormal }
+	: local_lreg			{ do e <- $1; return (CmmHinted e (inferCmmKind (CmmReg (CmmLocal e)))) }
+	| STRING local_lreg		{% do h <- parseCmmKind $1;
 					      return $ do
-						e <- $2; return (e,h) }
+						e <- $2; return (CmmHinted e h) }
 
 local_lreg :: { ExtFCode LocalReg }
 	: NAME			{ do e <- lookupName $1;
@@ -490,22 +517,22 @@ lreg	:: { ExtFCode CmmReg }
 					other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 	| GLOBALREG		{ return (CmmGlobal $1) }
 
-maybe_formals :: { [ExtFCode LocalReg] }
+maybe_formals_without_kinds :: { [ExtFCode LocalReg] }
 	: {- empty -}		{ [] }
-	| '(' formals0 ')'	{ $2 }
+	| '(' formals_without_kinds0 ')'	{ $2 }
 
-formals0 :: { [ExtFCode LocalReg] }
+formals_without_kinds0 :: { [ExtFCode LocalReg] }
 	: {- empty -}		{ [] }
-	| formals		{ $1 }
+	| formals_without_kinds		{ $1 }
 
-formals :: { [ExtFCode LocalReg] }
-	: formal ','		{ [$1] }
-	| formal		{ [$1] }
-	| formal ',' formals	{ $1 : $3 }
+formals_without_kinds :: { [ExtFCode LocalReg] }
+	: formal_without_kind ','		{ [$1] }
+	| formal_without_kind		{ [$1] }
+	| formal_without_kind ',' formals_without_kinds	{ $1 : $3 }
 
-formal :: { ExtFCode LocalReg }
+formal_without_kind :: { ExtFCode LocalReg }
 	: type NAME		{ newLocal defaultKind $1 $2 }
-	| STRING type NAME	{% do k <- parseKind $1;
+	| STRING type NAME	{% do k <- parseGCKind $1;
 				     return $ newLocal k $2 $3 }
 
 maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
@@ -656,24 +683,24 @@ parseSafety "safe"   = return (CmmSafe NoC_SRT)
 parseSafety "unsafe" = return CmmUnsafe
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
-parseHint :: String -> P MachHint
-parseHint "ptr"    = return PtrHint
-parseHint "signed" = return SignedHint
-parseHint "float"  = return FloatHint
-parseHint str      = fail ("unrecognised hint: " ++ str)
+parseCmmKind :: String -> P CmmKind
+parseCmmKind "ptr"    = return PtrHint
+parseCmmKind "signed" = return SignedHint
+parseCmmKind "float"  = return FloatHint
+parseCmmKind str      = fail ("unrecognised hint: " ++ str)
 
-parseKind :: String -> P Kind
-parseKind "ptr"    = return KindPtr
-parseKind str      = fail ("unrecognized kin: " ++ str)
+parseGCKind :: String -> P GCKind
+parseGCKind "ptr"    = return GCKindPtr
+parseGCKind str      = fail ("unrecognized kin: " ++ str)
 
-defaultKind :: Kind
-defaultKind = KindNonPtr
+defaultKind :: GCKind
+defaultKind = GCKindNonPtr
 
 -- labels are always pointers, so we might as well infer the hint
-inferHint :: CmmExpr -> MachHint
-inferHint (CmmLit (CmmLabel _)) = PtrHint
-inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
-inferHint _ = NoHint
+inferCmmKind :: CmmExpr -> CmmKind
+inferCmmKind (CmmLit (CmmLabel _)) = PtrHint
+inferCmmKind (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
+inferCmmKind _ = NoHint
 
 isPtrGlobalReg Sp		= True
 isPtrGlobalReg SpLim		= True
@@ -786,7 +813,7 @@ addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 addLabel :: FastString -> BlockId -> ExtCode
 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 
-newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
+newLocal :: GCKind -> MachRep -> FastString -> ExtFCode LocalReg
 newLocal kind ty name = do
    u <- code newUnique
    let reg = LocalReg u ty kind
@@ -797,8 +824,8 @@ newLocal kind ty name = do
 -- classifies these labels as dynamic, hence the code generator emits the
 -- PIC code for them.
 newImport :: FastString -> ExtFCode ()
-newImport name =
-       addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
+newImport name
+   = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
 
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
@@ -862,15 +889,17 @@ staticClosure cl_label info payload
 
 foreignCall
 	:: String
-	-> [ExtFCode (CmmFormal,MachHint)]
+	-> [ExtFCode CmmFormal]
 	-> ExtFCode CmmExpr
-	-> [ExtFCode (CmmExpr,MachHint)]
+	-> [ExtFCode CmmActual]
 	-> Maybe [GlobalReg]
         -> CmmSafety
+        -> CmmReturnInfo
         -> P ExtCode
-foreignCall conv_string results_code expr_code args_code vols safety
+foreignCall conv_string results_code expr_code args_code vols safety ret
   = do  convention <- case conv_string of
           "C" -> return CCallConv
+          "stdcall" -> return StdCallConv
           "C--" -> return CmmCallConv
           _ -> fail ("unknown calling convention: " ++ conv_string)
 	return $ do
@@ -880,20 +909,34 @@ foreignCall conv_string results_code expr_code args_code vols safety
 	  --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
           case convention of
             -- Temporary hack so at least some functions are CmmSafe
-            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
-            _ -> case safety of
+            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
+            _ ->
+              let expr' = adjCallTarget convention expr args in
+              case safety of
 	      CmmUnsafe ->
                 code (emitForeignCall' PlayRisky results 
-                   (CmmCallee expr convention) args vols NoC_SRT)
+                   (CmmCallee expr' convention) args vols NoC_SRT ret)
               CmmSafe srt ->
                 code (emitForeignCall' (PlaySafe unused) results 
-                   (CmmCallee expr convention) args vols NoC_SRT) where
+                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
 	        unused = panic "not used by emitForeignCall'"
 
+adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
+#ifdef mingw32_TARGET_OS
+-- On Windows, we have to add the '@N' suffix to the label when making
+-- a call with the stdcall calling convention.
+adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
+  where size (CmmHinted e _) = max wORD_SIZE (machRepByteWidth (cmmExprRep e))
+                 -- c.f. CgForeignCall.emitForeignCall
+#endif
+adjCallTarget _ expr _
+  = expr
+
 primCall
-	:: [ExtFCode (CmmFormal,MachHint)]
+	:: [ExtFCode CmmFormal]
 	-> FastString
-	-> [ExtFCode (CmmExpr,MachHint)]
+	-> [ExtFCode CmmActual]
 	-> Maybe [GlobalReg]
         -> CmmSafety
         -> P ExtCode
@@ -906,10 +949,10 @@ primCall results_code name args_code vols safety
 		case safety of
 		  CmmUnsafe ->
 		    code (emitForeignCall' PlayRisky results
-		      (CmmPrim p) args vols NoC_SRT)
+		      (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 		  CmmSafe srt ->
 		    code (emitForeignCall' (PlaySafe unused) results 
-		      (CmmPrim p) args vols NoC_SRT) where
+		      (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
 		    unused = panic "not used by emitForeignCall'"
 
 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
@@ -1060,7 +1103,7 @@ parseCmmFile dflags filename = do
 	let ms = getMessages pst
 	printErrorsAndWarnings dflags ms
         when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
-        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
 	return (Just cmm)
   where
 	no_module = panic "parseCmmFile: no module"