X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=60f3bb5623d220cfad6a87cbabcde5dde56e3458;hp=579df5e8ab21d4feb37710111b2e6cd57903fdab;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=d55027c917a101692ded11b6b1421052866df2d4 diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 579df5e..60f3bb5 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -3,13 +3,26 @@ -- (c) The University of Glasgow, 2004-2006 -- -- Parser for concrete Cmm. +-- This doesn't just parse the Cmm file, we also do some code generation +-- along the way for switches and foreign calls etc. -- ----------------------------------------------------------------------------- +-- TODO: Add support for interruptible/uninterruptible foreign call specification + { +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -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 +import CgMonad hiding (getDynFlags) +import CgExtCode import CgHeapery import CgUtils import CgProf @@ -23,16 +36,17 @@ import CgCallConv import CgClosure import CostCentre -import Cmm -import PprCmm +import BlockId +import OldCmm +import OldPprCmm() import CmmUtils import CmmLex import CLabel -import MachOp import SMRep import Lexer import ForeignCall +import Module import Literal import Unique import UniqFM @@ -45,14 +59,20 @@ import FastString import Panic import Constants import Outputable +import BasicTypes +import Bag ( emptyBag, unitBag ) +import Var import Control.Monad +import Data.Array import Data.Char ( ord ) import System.Exit #include "HsVersions.h" } +%expect 0 + %token ':' { L _ (CmmT_SpecChar ':') } ';' { L _ (CmmT_SpecChar ';') } @@ -103,8 +123,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) } @@ -115,6 +137,7 @@ import System.Exit 'bits64' { L _ (CmmT_bits64) } 'float32' { L _ (CmmT_float32) } 'float64' { L _ (CmmT_float64) } + 'gcptr' { L _ (CmmT_gcptr) } GLOBALREG { L _ (CmmT_GlobalReg $$) } NAME { L _ (CmmT_Name $$) } @@ -151,8 +174,9 @@ cmmtop :: { ExtCode } | cmmdata { $1 } | decl { $1 } | 'CLOSURE' '(' NAME ',' NAME lits ')' ';' - { do lits <- sequence $6; - staticClosure $3 $5 (map getLit lits) } + {% withThisPackage $ \pkg -> + do lits <- sequence $6; + staticClosure pkg $3 $5 (map getLit lits) } -- The only static closures in the RTS are dummy closures like -- stg_END_TSO_QUEUE_closure and stg_dummy_ret. We don't need @@ -175,22 +199,27 @@ statics :: { [ExtFCode [CmmStatic]] } -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. static :: { ExtFCode [CmmStatic] } - : NAME ':' { return [CmmDataLabel (mkRtsDataLabelFS $1)] } + : NAME ':' + {% withThisPackage $ \pkg -> + return [CmmDataLabel (mkCmmDataLabel pkg $1)] } + | type expr ';' { do e <- $2; return [CmmStaticLit (getLit e)] } | type ';' { return [CmmUninitialised - (machRepByteWidth $1)] } + (widthInBytes (typeWidth $1))] } | 'bits8' '[' ']' STRING ';' { return [mkString $4] } | 'bits8' '[' INT ']' ';' { return [CmmUninitialised (fromIntegral $3)] } | typenot8 '[' INT ']' ';' { return [CmmUninitialised - (machRepByteWidth $1 * + (widthInBytes (typeWidth $1) * fromIntegral $3)] } | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ - mkStaticClosure (mkRtsInfoLabelFS $3) + mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } -- arrays of closures required for the CHARLIKE & INTLIKE arrays @@ -200,50 +229,69 @@ 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_hints 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_hints ';' { 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) <- - getCgStmtsEC' $ loopDecls $ do { - formals <- sequence $2; - frame <- $3; - gc_block <- $4; - $6; - return (formals, frame, gc_block) } - blks <- code (cgStmtsToBlocks stmts) - code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) } + | NAME maybe_formals_without_hints maybe_gc_block maybe_frame '{' body '}' + {% withThisPackage $ \pkg -> + do newFunctionName $1 pkg + ((formals, gc_block, frame), stmts) <- + getCgStmtsEC' $ loopDecls $ do { + formals <- sequence $2; + gc_block <- $3; + frame <- $4; + $6; + return (formals, gc_block, frame) } + blks <- code (cgStmtsToBlocks stmts) + code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg $1) formals blks) } info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, closure type, description, type - { do prof <- profilingInfo $11 $13 - return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $9) + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $11 $13 + return (mkCmmEntryLabel pkg $3, + CmmInfoTable False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')' -- ptrs, nptrs, closure type, description, type, fun type - { do prof <- profilingInfo $11 $13 - return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $9) - (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 - (ArgSpec 0) + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $11 $13 + return (mkCmmEntryLabel pkg $3, + CmmInfoTable False prof (fromIntegral $9) + (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT + 0 -- Arity zero + (ArgSpec (fromIntegral $15)) + 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. + + -- 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 + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $11 $13 + return (mkCmmEntryLabel pkg $3, + CmmInfoTable False prof (fromIntegral $9) + (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) + (ArgSpec (fromIntegral $15)) zeroCLit), []) } -- we leave most of the fields zero here. This is only used @@ -251,36 +299,40 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')' -- ptrs, nptrs, tag, closure type, description, type - { do prof <- profilingInfo $13 $15 + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $13 $15 -- If profiling is on, this string gets duplicated, -- but that's the way the old code did it we can fix it some other time. - desc_lit <- code $ mkStringCLit $13 - return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $11) + desc_lit <- code $ mkStringCLit $13 + return (mkCmmEntryLabel pkg $3, + CmmInfoTable False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')' -- selector, closure type, description, type - { do prof <- profilingInfo $9 $11 - return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $7) + {% withThisPackage $ \pkg -> + do prof <- profilingInfo $9 $11 + return (mkCmmEntryLabel pkg $3, + CmmInfoTable False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } | 'INFO_TABLE_RET' '(' NAME ',' INT ')' -- closure type (no live regs) - { do let infoLabel = mkRtsInfoLabelFS $3 - return (mkRtsRetLabelFS $3, - CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + {% withThisPackage $ \pkg -> + do let infoLabel = mkCmmInfoLabel pkg $3 + return (mkCmmRetLabel pkg $3, + CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } - | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')' + | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' -- closure type, live regs - { do live <- sequence (map (liftM Just) $7) - return (mkRtsRetLabelFS $3, - CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + {% withThisPackage $ \pkg -> + do live <- sequence (map (liftM Just) $7) + return (mkCmmRetLabel pkg $3, + CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } @@ -290,16 +342,33 @@ body :: { ExtCode } | stmt body { do $1; $2 } decl :: { ExtCode } - : type names ';' { mapM_ (newLocal defaultKind $1) $2 } - | STRING type names ';' {% do k <- parseKind $1; - return $ mapM_ (newLocal k $2) $3 } - - | 'import' names ';' { mapM_ newImport $2 } + : type names ';' { mapM_ (newLocal $1) $2 } + | 'import' importNames ';' { mapM_ newImport $2 } | 'export' names ';' { return () } -- ignore exports + +-- an imported function name, with optional packageId +importNames + :: { [(FastString, CLabel)] } + : importName { [$1] } + | importName ',' importNames { $1 : $3 } + +importName + :: { (FastString, CLabel) } + + -- A label imported without an explicit packageId. + -- These are taken to come frome some foreign, unnamed package. + : NAME + { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) } + + -- A label imported with an explicit packageId. + | STRING NAME + { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } + + names :: { [FastString] } - : NAME { [$1] } - | NAME ',' names { $1 : $3 } + : NAME { [$1] } + | NAME ',' names { $1 : $3 } stmt :: { ExtCode } : ';' { nopEC } @@ -318,24 +387,30 @@ 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_hint_exprs0 ')' safety vols opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $9 $8 $10 } + | maybe_results 'prim' '%' NAME '(' cmm_hint_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? | NAME '(' exprs0 ')' ';' {% stmtMacro $1 $3 } | 'switch' maybe_range expr '{' arms default '}' - { doSwitch $2 $3 $5 $6 } + { do as <- sequence $5; doSwitch $2 $3 as $6 } | 'goto' NAME ';' { do l <- lookupLabel $2; stmtEC (CmmBranch l) } | '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 'goto' NAME + { do l <- lookupLabel $4; cmmRawIf $2 l } | 'if' bool_expr '{' body '}' else - { ifThenElse $2 $4 $6 } + { cmmIfThenElse $2 $4 $6 } + +opt_never_returns :: { CmmReturnInfo } + : { CmmMayReturn } + | 'never' 'returns' { CmmNeverReturns } bool_expr :: { ExtFCode BoolExpr } : bool_op { $1 } @@ -368,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) } : '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) } | {- empty -} { Nothing } -arms :: { [([Int],ExtCode)] } +arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] } : {- empty -} { [] } | arm arms { $1 : $2 } -arm :: { ([Int],ExtCode) } - : 'case' ints ':' '{' body '}' { ($2, $5) } +arm :: { ExtFCode ([Int],Either BlockId ExtCode) } + : 'case' ints ':' arm_body { do b <- $4; return ($2, b) } + +arm_body :: { ExtFCode (Either BlockId ExtCode) } + : '{' body '}' { return (Right $2) } + | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) } ints :: { [Int] } : INT { [ fromIntegral $1 ] } @@ -385,6 +464,8 @@ default :: { Maybe ExtCode } -- 'default' branches | {- empty -} { Nothing } +-- Note: OldCmm doesn't support a first class 'else' statement, though +-- CmmNode does. else :: { ExtCode } : {- empty -} { nopEC } | 'else' '{' body '}' { $3 } @@ -415,8 +496,8 @@ expr :: { ExtFCode CmmExpr } | expr0 { $1 } expr0 :: { ExtFCode CmmExpr } - : INT maybe_ty { return (CmmLit (CmmInt $1 $2)) } - | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 $2)) } + : INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) } + | FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) } | STRING { do s <- code (mkStringCLit $1); return (CmmLit s) } | reg { $1 } @@ -426,27 +507,27 @@ expr0 :: { ExtFCode CmmExpr } -- leaving out the type of a literal gives you the native word size in C-- -maybe_ty :: { MachRep } - : {- empty -} { wordRep } +maybe_ty :: { CmmType } + : {- empty -} { bWord } | '::' type { $2 } -maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] } +maybe_actuals :: { [ExtFCode HintedCmmActual] } : {- empty -} { [] } - | '(' hint_exprs0 ')' { $2 } + | '(' cmm_hint_exprs0 ')' { $2 } -hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] } +cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] } : {- empty -} { [] } - | hint_exprs { $1 } + | cmm_hint_exprs { $1 } -hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] } - : hint_expr { [$1] } - | hint_expr ',' hint_exprs { $1 : $3 } +cmm_hint_exprs :: { [ExtFCode HintedCmmActual] } + : cmm_hint_expr { [$1] } + | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } -hint_expr :: { ExtFCode (CmmExpr, MachHint) } - : expr { do e <- $1; return (e, inferHint e) } - | expr STRING {% do h <- parseHint $2; +cmm_hint_expr :: { ExtFCode HintedCmmActual } + : expr { do e <- $1; return (CmmHinted e (inferCmmHint e)) } + | expr STRING {% do h <- parseCmmHint $2; return $ do - e <- $1; return (e,h) } + e <- $1; return (CmmHinted e h) } exprs0 :: { [ExtFCode CmmExpr] } : {- empty -} { [] } @@ -460,20 +541,20 @@ reg :: { ExtFCode CmmExpr } : NAME { lookupName $1 } | GLOBALREG { return (CmmReg (CmmGlobal $1)) } -maybe_results :: { [ExtFCode (CmmFormal, MachHint)] } +maybe_results :: { [ExtFCode HintedCmmFormal] } : {- 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 HintedCmmFormal] } + : 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 HintedCmmFormal } + : local_lreg { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) } + | STRING local_lreg {% do h <- parseCmmHint $1; return $ do - e <- $2; return (e,h) } + e <- $2; return (CmmHinted e h) } local_lreg :: { ExtFCode LocalReg } : NAME { do e <- lookupName $1; @@ -490,23 +571,21 @@ lreg :: { ExtFCode CmmReg } other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } | GLOBALREG { return (CmmGlobal $1) } -maybe_formals :: { [ExtFCode LocalReg] } +maybe_formals_without_hints :: { [ExtFCode LocalReg] } : {- empty -} { [] } - | '(' formals0 ')' { $2 } + | '(' formals_without_hints0 ')' { $2 } -formals0 :: { [ExtFCode LocalReg] } +formals_without_hints0 :: { [ExtFCode LocalReg] } : {- empty -} { [] } - | formals { $1 } + | formals_without_hints { $1 } -formals :: { [ExtFCode LocalReg] } - : formal ',' { [$1] } - | formal { [$1] } - | formal ',' formals { $1 : $3 } +formals_without_hints :: { [ExtFCode LocalReg] } + : formal_without_hint ',' { [$1] } + | formal_without_hint { [$1] } + | formal_without_hint ',' formals_without_hints { $1 : $3 } -formal :: { ExtFCode LocalReg } - : type NAME { newLocal defaultKind $1 $2 } - | STRING type NAME {% do k <- parseKind $1; - return $ newLocal k $2 $3 } +formal_without_hint :: { ExtFCode LocalReg } + : type NAME { newLocal $1 $2 } maybe_frame :: { ExtFCode (Maybe UpdateFrame) } : {- empty -} { return Nothing } @@ -519,16 +598,17 @@ maybe_gc_block :: { ExtFCode (Maybe BlockId) } | 'goto' NAME { do l <- lookupLabel $2; return (Just l) } -type :: { MachRep } - : 'bits8' { I8 } +type :: { CmmType } + : 'bits8' { b8 } | typenot8 { $1 } -typenot8 :: { MachRep } - : 'bits16' { I16 } - | 'bits32' { I32 } - | 'bits64' { I64 } - | 'float32' { F32 } - | 'float64' { F64 } +typenot8 :: { CmmType } + : 'bits16' { b16 } + | 'bits32' { b32 } + | 'bits64' { b64 } + | 'float32' { f32 } + | 'float64' { f64 } + | 'gcptr' { gcWord } { section :: String -> Section section "text" = Text @@ -545,17 +625,17 @@ mkString s = CmmString (map (fromIntegral.ord) s) -- argument. We assume that this is correct: for MachOps that don't have -- symmetrical args (e.g. shift ops), the first arg determines the type of -- the op. -mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr +mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr mkMachOp fn args = do arg_exprs <- sequence args - return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs) + return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs) getLit :: CmmExpr -> CmmLit getLit (CmmLit l) = l getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r getLit _ = panic "invalid literal" -- TODO messy failure -nameToMachOp :: FastString -> P (MachRep -> MachOp) +nameToMachOp :: FastString -> P (Width -> MachOp) nameToMachOp name = case lookupUFM machOps name of Nothing -> fail ("unknown primitive " ++ unpackFS name) @@ -573,16 +653,16 @@ exprOp name args_code = exprMacros :: UniqFM ([CmmExpr] -> CmmExpr) exprMacros = listToUFM [ - ( FSLIT("ENTRY_CODE"), \ [x] -> entryCode x ), - ( FSLIT("INFO_PTR"), \ [x] -> closureInfoPtr x ), - ( FSLIT("STD_INFO"), \ [x] -> infoTable x ), - ( FSLIT("FUN_INFO"), \ [x] -> funInfoTable x ), - ( FSLIT("GET_ENTRY"), \ [x] -> entryCode (closureInfoPtr x) ), - ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ), - ( 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 "ENTRY_CODE", \ [x] -> entryCode x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ), + ( fsLit "STD_INFO", \ [x] -> infoTable x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable x ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode (closureInfoPtr x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ), + ( 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 ) ] -- we understand a subset of C-- primitives: @@ -609,15 +689,7 @@ machOps = listToUFM $ ( "gtu", MO_U_Gt ), ( "ltu", MO_U_Lt ), - ( "flt", MO_S_Lt ), - ( "fle", MO_S_Le ), - ( "feq", MO_Eq ), - ( "fne", MO_Ne ), - ( "fgt", MO_S_Gt ), - ( "fge", MO_S_Ge ), - ( "fneg", MO_S_Neg ), - - ( "and", MO_And ), + ( "and", MO_And ), ( "or", MO_Or ), ( "xor", MO_Xor ), ( "com", MO_Not ), @@ -625,63 +697,76 @@ machOps = listToUFM $ ( "shrl", MO_U_Shr ), ( "shra", MO_S_Shr ), - ( "lobits8", flip MO_U_Conv I8 ), - ( "lobits16", flip MO_U_Conv I16 ), - ( "lobits32", flip MO_U_Conv I32 ), - ( "lobits64", flip MO_U_Conv I64 ), - ( "sx16", flip MO_S_Conv I16 ), - ( "sx32", flip MO_S_Conv I32 ), - ( "sx64", flip MO_S_Conv I64 ), - ( "zx16", flip MO_U_Conv I16 ), - ( "zx32", flip MO_U_Conv I32 ), - ( "zx64", flip MO_U_Conv I64 ), - ( "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 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 ) + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "f2i8", flip MO_FS_Conv W8 ), + ( "f2i16", flip MO_FS_Conv W16 ), + ( "f2i32", flip MO_FS_Conv W32 ), + ( "f2i64", flip MO_FS_Conv W64 ), + ( "i2f32", flip MO_SF_Conv W32 ), + ( "i2f64", flip MO_SF_Conv W64 ) ] callishMachOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ - ( "write_barrier", MO_WriteBarrier ) + ( "write_barrier", MO_WriteBarrier ), + ( "memcpy", MO_Memcpy ), + ( "memset", MO_Memset ), + ( "memmove", MO_Memmove ) -- ToDo: the rest, maybe ] parseSafety :: String -> P CmmSafety parseSafety "safe" = return (CmmSafe NoC_SRT) parseSafety "unsafe" = return CmmUnsafe +parseSafety "interruptible" = return CmmInterruptible 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) - -parseKind :: String -> P Kind -parseKind "ptr" = return KindPtr -parseKind str = fail ("unrecognized kin: " ++ str) - -defaultKind :: Kind -defaultKind = KindNonPtr +parseCmmHint :: String -> P ForeignHint +parseCmmHint "ptr" = return AddrHint +parseCmmHint "signed" = return SignedHint +parseCmmHint str = fail ("unrecognised hint: " ++ str) -- 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 - -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg _ = False +inferCmmHint :: CmmExpr -> ForeignHint +inferCmmHint (CmmLit (CmmLabel _)) = AddrHint +inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint +inferCmmHint _ = NoHint + +isPtrGlobalReg Sp = True +isPtrGlobalReg SpLim = True +isPtrGlobalReg Hp = True +isPtrGlobalReg HpLim = True +isPtrGlobalReg CurrentTSO = True +isPtrGlobalReg CurrentNursery = True +isPtrGlobalReg (VanillaReg _ VGcPtr) = True +isPtrGlobalReg _ = False happyError :: P a happyError = srcParseFail @@ -699,150 +784,48 @@ stmtMacro fun args_code = do stmtMacros :: UniqFM ([CmmExpr] -> Code) stmtMacros = listToUFM [ - ( FSLIT("CCS_ALLOC"), \[words,ccs] -> profAlloc words ccs ), - ( FSLIT("CLOSE_NURSERY"), \[] -> emitCloseNursery ), - ( FSLIT("ENTER_CCS_PAP_CL"), \[e] -> enterCostCentrePAP e ), - ( FSLIT("ENTER_CCS_THUNK"), \[e] -> enterCostCentreThunk e ), - ( FSLIT("HP_CHK_GEN"), \[words,liveness,reentry] -> + ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), + ( fsLit "ENTER_CCS_PAP_CL", \[e] -> enterCostCentrePAP e ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + ( fsLit "HP_CHK_GEN", \[words,liveness,reentry] -> hpChkGen words liveness reentry ), - ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ), - ( FSLIT("LOAD_THREAD_STATE"), \[] -> emitLoadThreadState ), - ( FSLIT("LDV_ENTER"), \[e] -> ldvEnter e ), - ( FSLIT("LDV_RECORD_CREATE"), \[e] -> ldvRecordCreate e ), - ( FSLIT("OPEN_NURSERY"), \[] -> emitOpenNursery ), - ( FSLIT("PUSH_UPD_FRAME"), \[sp,e] -> emitPushUpdateFrame sp e ), - ( FSLIT("SAVE_THREAD_STATE"), \[] -> emitSaveThreadState ), - ( FSLIT("SET_HDR"), \[ptr,info,ccs] -> + ( fsLit "HP_CHK_NP_ASSIGN_SP0", \[e,f] -> hpChkNodePointsAssignSp0 e f ), + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), + ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), + ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + ( fsLit "SET_HDR", \[ptr,info,ccs] -> emitSetDynHdr ptr info ccs ), - ( FSLIT("STK_CHK_GEN"), \[words,liveness,reentry] -> + ( fsLit "STK_CHK_GEN", \[words,liveness,reentry] -> stkChkGen words liveness reentry ), - ( FSLIT("STK_CHK_NP"), \[e] -> stkChkNodePoints e ), - ( FSLIT("TICK_ALLOC_PRIM"), \[hdr,goods,slop] -> + ( fsLit "STK_CHK_NP", \[e] -> stkChkNodePoints e ), + ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> tickyAllocPrim hdr goods slop ), - ( FSLIT("TICK_ALLOC_PAP"), \[goods,slop] -> + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> tickyAllocPAP goods slop ), - ( FSLIT("TICK_ALLOC_UP_THK"), \[goods,slop] -> + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> tickyAllocThunk goods slop ), - ( FSLIT("UPD_BH_UPDATABLE"), \[] -> emitBlackHoleCode False ), - ( FSLIT("UPD_BH_SINGLE_ENTRY"), \[] -> emitBlackHoleCode True ), - - ( FSLIT("RET_P"), \[a] -> emitRetUT [(PtrArg,a)]), - ( FSLIT("RET_N"), \[a] -> emitRetUT [(NonPtrArg,a)]), - ( FSLIT("RET_PP"), \[a,b] -> emitRetUT [(PtrArg,a),(PtrArg,b)]), - ( 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)]) + ( fsLit "UPD_BH_UPDATABLE", \[] -> emitBlackHoleCode False ), + ( fsLit "UPD_BH_SINGLE_ENTRY", \[] -> emitBlackHoleCode True ), + + ( fsLit "RET_P", \[a] -> emitRetUT [(PtrArg,a)]), + ( fsLit "RET_N", \[a] -> emitRetUT [(NonPtrArg,a)]), + ( fsLit "RET_PP", \[a,b] -> emitRetUT [(PtrArg,a),(PtrArg,b)]), + ( 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_NNN", \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]), + ( fsLit "RET_NNNN", \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]), + ( 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)]) ] --- ----------------------------------------------------------------------------- --- Our extended FCode monad. - --- We add a mapping from names to CmmExpr, to support local variable names in --- the concrete C-- code. The unique supply of the underlying FCode monad --- is used to grab a new unique for each local variable. - --- In C--, a local variable can be declared anywhere within a proc, --- and it scopes from the beginning of the proc to the end. Hence, we have --- to collect declarations as we parse the proc, and feed the environment --- back in circularly (to avoid a two-pass algorithm). - -data Named = Var CmmExpr | Label BlockId -type Decls = [(FastString,Named)] -type Env = UniqFM Named - -newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } - -type ExtCode = ExtFCode () - -returnExtFC a = EC $ \e s -> return (s, a) -thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s' - -instance Monad ExtFCode where - (>>=) = thenExtFC - return = returnExtFC - --- This function takes the variable decarations and imports and makes --- an environment, which is looped back into the computation. In this --- way, we can have embedded declarations that scope over the whole --- procedure, and imports that scope over the entire module. --- Discards the local declaration contained within decl' -loopDecls :: ExtFCode a -> ExtFCode a -loopDecls (EC fcode) = - EC $ \e globalDecls -> do - (decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) - return (globalDecls, a) - -getEnv :: ExtFCode Env -getEnv = EC $ \e s -> return (s, e) - -addVarDecl :: FastString -> CmmExpr -> ExtCode -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 kind ty name = do - u <- code newUnique - let reg = LocalReg u ty kind - addVarDecl name (CmmReg (CmmLocal reg)) - return reg - --- Creates a foreign label in the import. CLabel's labelDynamic --- 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))) - -newLabel :: FastString -> ExtFCode BlockId -newLabel name = do - u <- code newUnique - addLabel name (BlockId u) - return (BlockId u) - -lookupLabel :: FastString -> ExtFCode BlockId -lookupLabel name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (Label l) -> l - _other -> BlockId (newTagUnique (getUnique name) 'L') - --- Unknown names are treated as if they had been 'import'ed. --- This saves us a lot of bother in the RTS sources, at the expense of --- deferring some errors to link time. -lookupName :: FastString -> ExtFCode CmmExpr -lookupName name = do - env <- getEnv - return $ - case lookupUFM env name of - Just (Var e) -> e - _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name)) - --- Lifting FCode computations into the ExtFCode monad: -code :: FCode a -> ExtFCode a -code fc = EC $ \e s -> do r <- fc; return (s, r) - -code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) - -> ExtFCode b -> ExtFCode c -code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c) - -nopEC = code nopC -stmtEC stmt = code (stmtC stmt) -stmtsEC stmts = code (stmtsC stmts) -getCgStmtsEC = code2 getCgStmts' -getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f) - where f ((decl, b), c) = return ((decl, b), (b, c)) - -forkLabelledCodeEC ec = do - stmts <- getCgStmtsEC ec - code (forkCgStmts stmts) profilingInfo desc_str ty_str = do @@ -855,45 +838,64 @@ profilingInfo desc_str ty_str = do return (ProfilingInfo lit1 lit2) -staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode -staticClosure cl_label info payload - = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits - where lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] [] +staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode +staticClosure pkg cl_label info payload + = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits + where lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] foreignCall :: String - -> [ExtFCode (CmmFormal,MachHint)] + -> [ExtFCode HintedCmmFormal] -> ExtFCode CmmExpr - -> [ExtFCode (CmmExpr,MachHint)] + -> [ExtFCode HintedCmmActual] -> 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)) - _ -> 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 - (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'" + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmCallee expr' convention) args vols NoC_SRT ret) + +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 (widthInBytes (typeWidth (cmmExprType e))) + -- c.f. CgForeignCall.emitForeignCall +#endif +adjCallTarget _ expr _ + = expr primCall - :: [ExtFCode (CmmFormal,MachHint)] + :: [ExtFCode HintedCmmFormal] -> FastString - -> [ExtFCode (CmmExpr,MachHint)] + -> [ExtFCode HintedCmmActual] -> Maybe [GlobalReg] -> CmmSafety -> P ExtCode @@ -906,13 +908,16 @@ 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'" + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmPrim p) args vols NoC_SRT CmmMayReturn) -doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode +doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code = do addr <- addr_code val <- val_code @@ -921,9 +926,11 @@ doStore rep addr_code val_code -- mismatch to be flagged by cmm-lint. If we don't do this, then -- the store will happen at the wrong type, and the error will not -- be noticed. + let val_width = typeWidth (cmmExprType val) + rep_width = typeWidth rep let coerce_val - | cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val] - | otherwise = val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val stmtEC (CmmStore addr coerce_val) -- Return an unboxed tuple. @@ -931,9 +938,11 @@ emitRetUT :: [(CgRep,CmmExpr)] -> Code emitRetUT args = do tickyUnboxedTupleReturn (length args) -- TICK (sp, stmts) <- pushUnboxedTuple 0 args - emitStmts stmts + emitSimultaneously stmts -- NB. the args might overlap with the stack slots + -- or regs that we assign to, so better use + -- simultaneous assignments here (#3546) when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) []) + stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) []) -- TODO (when using CPS): emitStmt (CmmReturn (map snd args)) -- ----------------------------------------------------------------------------- @@ -947,7 +956,7 @@ data BoolExpr -- ToDo: smart constructors which simplify the boolean expression. -ifThenElse cond then_part else_part = do +cmmIfThenElse cond then_part else_part = do then_id <- code newLabelC join_id <- code newLabelC c <- cond @@ -959,6 +968,10 @@ ifThenElse cond then_part else_part = do -- fall through to join code (labelC join_id) +cmmRawIf cond then_id = do + c <- cond + emitCond c then_id + -- 'emitCond cond true_id' emits code to test whether the cond is true, -- branching to true_id if so, and falling through otherwise. emitCond (BoolTest e) then_id = do @@ -998,7 +1011,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do -- optional range on the switch (eg. switch [0..7] {...}), or by -- the minimum/maximum values from the branches. -doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)] +doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)] -> Maybe ExtCode -> ExtCode doSwitch mb_range scrut arms deflt = do @@ -1025,12 +1038,12 @@ doSwitch mb_range scrut arms deflt -- ToDo: check for out of range and jump to default if necessary stmtEC (CmmSwitch expr entries) where - emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)] - emitArm (ints,code) = do + emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do blockid <- forkLabelledCodeEC code return [ (i,blockid) | i <- ints ] - -- ----------------------------------------------------------------------------- -- Putting it all together @@ -1038,30 +1051,33 @@ doSwitch mb_range scrut arms deflt -- knows about here. initEnv :: Env initEnv = listToUFM [ - ( FSLIT("SIZEOF_StgHeader"), - Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )), - ( FSLIT("SIZEOF_StgInfoTable"), - Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )) + ( fsLit "SIZEOF_StgHeader", + Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )), + ( fsLit "SIZEOF_StgInfoTable", + Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) )) ] -parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm) +parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm) parseCmmFile dflags filename = do showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let - init_loc = mkSrcLoc (mkFastString filename) 1 0 - init_state = (mkPState buf init_loc dflags) { lex_state = [0] } + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (mkPState dflags buf init_loc) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. case unP cmmParse init_state of - PFailed span err -> do printError span err; return Nothing + PFailed span err -> do + let msg = mkPlainErrMsg span err + return ((emptyBag, unitBag msg), Nothing) 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) + cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ())) + let ms = getMessages pst + if (errorsFound dflags ms) + then return (ms, Nothing) + else do + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" }