X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=bd7863128ff476ad05e43b71e162ba30612042f6;hp=579df5e8ab21d4feb37710111b2e6cd57903fdab;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=d55027c917a101692ded11b6b1421052866df2d4 diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 579df5e..bd78631 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/CodingStyle#Warnings +-- for details + module CmmParse ( parseCmmFile ) where import CgMonad @@ -103,8 +110,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,15 +209,15 @@ 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 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) } @@ -217,14 +226,14 @@ cmmproc :: { ExtCode } 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 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 +257,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 @@ -318,8 +340,8 @@ 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 'foreign' STRING expr '(' hint_exprs0 ')' safety vols opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $9 $8 $10 } | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' safety vols ';' {% primCall $1 $4 $6 $9 $8 } -- stmt-level macros, stealing syntax from ordinary C-- function calls. @@ -337,6 +359,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) } @@ -867,27 +893,29 @@ foreignCall -> [ExtFCode (CmmExpr,MachHint)] -> 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 results <- sequence results_code expr <- expr_code args <- sequence args_code - --code (stmtC (CmmCall (CmmForeignCall expr convention) results args 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 (CmmForeignCall expr convention) results args safety)) + CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret)) _ -> case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results - (CmmForeignCall expr convention) args vols NoC_SRT) + (CmmCallee expr convention) args vols NoC_SRT ret) CmmSafe srt -> code (emitForeignCall' (PlaySafe unused) results - (CmmForeignCall expr convention) args vols NoC_SRT) where + (CmmCallee expr convention) args vols NoC_SRT ret) where unused = panic "not used by emitForeignCall'" primCall @@ -906,10 +934,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