X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=33a4b809d81e863bd336eea30421d23f7d5e240c;hp=2f42f8cab579d4d50b19347eda08482e87349e42;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=ec6e7468ff70c40c2f24792cec0261512ee32431 diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 2f42f8c..33a4b80 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -3,11 +3,23 @@ -- (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 + { -{-# OPTIONS -w #-} +{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} +-- The NoMonomorphismRestriction deals with a Happy infelicity +-- With OutsideIn's more conservativ monomorphism restriction +-- we aren't generalising +-- notHappyAtAll = error "urk" +-- which is terrible. Switching off the restriction allows +-- the generalisation. Better would be to make Happy generate +-- an appropriate signature. +-- -- 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 @@ -16,7 +28,8 @@ module CmmParse ( parseCmmFile ) where -import CgMonad +import CgMonad hiding (getDynFlags) +import CgExtCode import CgHeapery import CgUtils import CgProf @@ -30,16 +43,17 @@ import CgCallConv import CgClosure import CostCentre +import BlockId import Cmm import PprCmm import CmmUtils import CmmLex import CLabel -import MachOp import SMRep import Lexer import ForeignCall +import Module import Literal import Unique import UniqFM @@ -52,6 +66,9 @@ import FastString import Panic import Constants import Outputable +import BasicTypes +import Bag ( emptyBag, unitBag ) +import Var import Control.Monad import Data.Array @@ -61,6 +78,8 @@ import System.Exit #include "HsVersions.h" } +%expect 0 + %token ':' { L _ (CmmT_SpecChar ':') } ';' { L _ (CmmT_SpecChar ';') } @@ -125,6 +144,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 $$) } @@ -161,8 +181,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 @@ -185,22 +206,25 @@ 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 (mkForeignLabel $3 Nothing True) + mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData) -- mkForeignLabel because these are only used -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } @@ -212,7 +236,7 @@ lits :: { [ExtFCode CmmExpr] } cmmproc :: { ExtCode } -- TODO: add real SRT/info tables to parsed Cmm - : info maybe_formals_without_kinds maybe_gc_block maybe_frame '{' body '}' + : 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; @@ -224,38 +248,43 @@ cmmproc :: { ExtCode } blks <- code (cgStmtsToBlocks stmts) code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) } - | info maybe_formals_without_kinds ';' + | 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_without_kinds maybe_gc_block maybe_frame '{' body '}' - { do ((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) (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 @@ -264,11 +293,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- 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) + {% 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 @@ -276,36 +306,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 ',' formals_without_kinds0 ')' + | '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) } @@ -315,16 +349,33 @@ body :: { ExtCode } | stmt body { do $1; $2 } decl :: { ExtCode } - : type names ';' { mapM_ (newLocal defaultKind $1) $2 } - | STRING type names ';' {% do k <- parseGCKind $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 } @@ -343,9 +394,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 '(' cmm_kind_exprs0 ')' safety vols opt_never_returns ';' + | 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_kind_exprs0 ')' safety vols ';' + | 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? @@ -444,8 +495,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 } @@ -455,25 +506,25 @@ 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 CmmActual] } +maybe_actuals :: { [ExtFCode HintedCmmActual] } : {- empty -} { [] } - | '(' cmm_kind_exprs0 ')' { $2 } + | '(' cmm_hint_exprs0 ')' { $2 } -cmm_kind_exprs0 :: { [ExtFCode CmmActual] } +cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] } : {- empty -} { [] } - | cmm_kind_exprs { $1 } + | cmm_hint_exprs { $1 } -cmm_kind_exprs :: { [ExtFCode CmmActual] } - : cmm_kind_expr { [$1] } - | cmm_kind_expr ',' cmm_kind_exprs { $1 : $3 } +cmm_hint_exprs :: { [ExtFCode HintedCmmActual] } + : cmm_hint_expr { [$1] } + | cmm_hint_expr ',' cmm_hint_exprs { $1 : $3 } -cmm_kind_expr :: { ExtFCode CmmActual } - : expr { do e <- $1; return (CmmHinted e (inferCmmKind e)) } - | expr STRING {% do h <- parseCmmKind $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 (CmmHinted e h) } @@ -489,18 +540,18 @@ reg :: { ExtFCode CmmExpr } : NAME { lookupName $1 } | GLOBALREG { return (CmmReg (CmmGlobal $1)) } -maybe_results :: { [ExtFCode CmmFormal] } +maybe_results :: { [ExtFCode HintedCmmFormal] } : {- empty -} { [] } | '(' cmm_formals ')' '=' { $2 } -cmm_formals :: { [ExtFCode CmmFormal] } +cmm_formals :: { [ExtFCode HintedCmmFormal] } : cmm_formal { [$1] } | cmm_formal ',' { [$1] } | cmm_formal ',' cmm_formals { $1 : $3 } -cmm_formal :: { ExtFCode CmmFormal } - : local_lreg { do e <- $1; return (CmmHinted e (inferCmmKind (CmmReg (CmmLocal e)))) } - | STRING local_lreg {% do h <- parseCmmKind $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 (CmmHinted e h) } @@ -519,23 +570,21 @@ lreg :: { ExtFCode CmmReg } other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") } | GLOBALREG { return (CmmGlobal $1) } -maybe_formals_without_kinds :: { [ExtFCode LocalReg] } +maybe_formals_without_hints :: { [ExtFCode LocalReg] } : {- empty -} { [] } - | '(' formals_without_kinds0 ')' { $2 } + | '(' formals_without_hints0 ')' { $2 } -formals_without_kinds0 :: { [ExtFCode LocalReg] } +formals_without_hints0 :: { [ExtFCode LocalReg] } : {- empty -} { [] } - | formals_without_kinds { $1 } + | formals_without_hints { $1 } -formals_without_kinds :: { [ExtFCode LocalReg] } - : formal_without_kind ',' { [$1] } - | formal_without_kind { [$1] } - | formal_without_kind ',' formals_without_kinds { $1 : $3 } +formals_without_hints :: { [ExtFCode LocalReg] } + : formal_without_hint ',' { [$1] } + | formal_without_hint { [$1] } + | formal_without_hint ',' formals_without_hints { $1 : $3 } -formal_without_kind :: { ExtFCode LocalReg } - : type NAME { newLocal defaultKind $1 $2 } - | STRING type NAME {% do k <- parseGCKind $1; - return $ newLocal k $2 $3 } +formal_without_hint :: { ExtFCode LocalReg } + : type NAME { newLocal $1 $2 } maybe_frame :: { ExtFCode (Maybe UpdateFrame) } : {- empty -} { return Nothing } @@ -548,16 +597,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 @@ -574,17 +624,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) @@ -654,24 +704,27 @@ 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 ) + ( "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 $ @@ -683,34 +736,28 @@ callishMachOps = listToUFM $ parseSafety :: String -> P CmmSafety parseSafety "safe" = return (CmmSafe NoC_SRT) parseSafety "unsafe" = return CmmUnsafe +parseSafety "interruptible" = return CmmInterruptible parseSafety str = fail ("unrecognised safety: " ++ str) -parseCmmKind :: String -> P CmmKind -parseCmmKind "ptr" = return PtrHint -parseCmmKind "signed" = return SignedHint -parseCmmKind "float" = return FloatHint -parseCmmKind str = fail ("unrecognised hint: " ++ str) - -parseGCKind :: String -> P GCKind -parseGCKind "ptr" = return GCKindPtr -parseGCKind str = fail ("unrecognized kin: " ++ str) - -defaultKind :: GCKind -defaultKind = GCKindNonPtr +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 -inferCmmKind :: CmmExpr -> CmmKind -inferCmmKind (CmmLit (CmmLabel _)) = PtrHint -inferCmmKind (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint -inferCmmKind _ = 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 @@ -764,115 +811,12 @@ stmtMacros = listToUFM [ ( 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 :: GCKind -> 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 @@ -885,16 +829,16 @@ 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] + -> [ExtFCode HintedCmmFormal] -> ExtFCode CmmExpr - -> [ExtFCode CmmActual] + -> [ExtFCode HintedCmmActual] -> Maybe [GlobalReg] -> CmmSafety -> CmmReturnInfo @@ -923,6 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret code (emitForeignCall' (PlaySafe unused) results (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 @@ -930,16 +877,16 @@ adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr -- 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)) + where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e))) -- c.f. CgForeignCall.emitForeignCall #endif adjCallTarget _ expr _ = expr primCall - :: [ExtFCode CmmFormal] + :: [ExtFCode HintedCmmFormal] -> FastString - -> [ExtFCode CmmActual] + -> [ExtFCode HintedCmmActual] -> Maybe [GlobalReg] -> CmmSafety -> P ExtCode @@ -957,8 +904,11 @@ primCall results_code name args_code vols safety code (emitForeignCall' (PlaySafe unused) results (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 @@ -967,9 +917,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. @@ -977,9 +929,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)) -- ----------------------------------------------------------------------------- @@ -1085,29 +1039,32 @@ doSwitch mb_range scrut arms deflt initEnv :: Env initEnv = listToUFM [ ( fsLit "SIZEOF_StgHeader", - Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )), + Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )), ( fsLit "SIZEOF_StgInfoTable", - Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )) + 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 = mkSrcLoc (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" (ppr 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" }