import UniqFM
import SrcLoc
import DynFlags ( DynFlags, DynFlag(..) )
-import Packages ( HomeModules )
import StaticFlags ( opt_SccProfilingOn )
import ErrUtils ( printError, dumpIfSet_dyn, showPass )
import StringBuffer ( hGetStringBuffer )
'if' { L _ (CmmT_if) }
'jump' { L _ (CmmT_jump) }
'foreign' { L _ (CmmT_foreign) }
+ 'prim' { L _ (CmmT_prim) }
'import' { L _ (CmmT_import) }
'switch' { L _ (CmmT_switch) }
'case' { L _ (CmmT_case) }
stmt :: { ExtCode }
: ';' { nopEC }
- | block_id ':' { code (labelC $1) }
+ | NAME ':'
+ { do l <- newLabel $1; code (labelC l) }
| lreg '=' expr ';'
{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
| lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
{% let result = do r <- $1; return (r,NoHint) in
foreignCall $4 [result] $5 $7 $9 }
+ | 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
+ {% primCall [] $3 $5 $7 }
+ | lreg '=' 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
+ {% let result = do r <- $1; return (r,NoHint) in
+ primCall [result] $5 $7 $9 }
| STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
{% do h <- parseHint $1;
let result = do r <- $2; return (r,h) in
{% stmtMacro $1 $3 }
| 'switch' maybe_range expr '{' arms default '}'
{ doSwitch $2 $3 $5 $6 }
- | 'goto' block_id ';'
- { stmtEC (CmmBranch $2) }
+ | 'goto' NAME ';'
+ { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
| 'jump' expr {-maybe_actuals-} ';'
{ do e <- $2; stmtEC (CmmJump e []) }
| 'if' bool_expr '{' body '}' else
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
| GLOBALREG { return (CmmGlobal $1) }
-block_id :: { BlockId }
- : NAME { BlockId (newTagUnique (getUnique $1) 'L') }
- -- TODO: ugh. The unique of a FastString has a null
- -- tag, so we have to put our own tag on. We should
- -- really make a new unique for every label, and keep
- -- them in an environment.
-
type :: { MachRep }
: 'bits8' { I8 }
| typenot8 { $1 }
( "i2f64", flip MO_S_Conv F64 )
]
+callishMachOps = listToUFM $
+ map (\(x, y) -> (mkFastString x, y)) [
+ ( "write_barrier", MO_WriteBarrier )
+ -- ToDo: the rest, maybe
+ ]
+
parseHint :: String -> P MachHint
parseHint "ptr" = return PtrHint
parseHint "signed" = return SignedHint
-- to collect declarations as we parse the proc, and feed the environment
-- back in circularly (to avoid a two-pass algorithm).
-type Decls = [(FastString,CmmExpr)]
-type Env = UniqFM CmmExpr
+data Named = Var CmmExpr | Label BlockId
+type Decls = [(FastString,Named)]
+type Env = UniqFM Named
newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
getEnv = EC $ \e s -> return (s, e)
addVarDecl :: FastString -> CmmExpr -> ExtCode
-addVarDecl var expr = EC $ \e s -> return ((var,expr):s, ())
+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 :: MachRep -> FastString -> ExtCode
newLocal ty name = do
u <- code newUnique
addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
+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.
env <- getEnv
return $
case lookupUFM env name of
- Nothing -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
- Just e -> e
+ Just (Var e) -> e
+ _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
-- Lifting FCode computations into the ExtFCode monad:
code :: FCode a -> ExtFCode a
foreignCall conv _ _ _ _
= fail ("unknown calling convention: " ++ conv)
+primCall
+ :: [ExtFCode (CmmReg,MachHint)]
+ -> FastString
+ -> [ExtFCode (CmmExpr,MachHint)]
+ -> Maybe [GlobalReg] -> P ExtCode
+primCall results_code name args_code vols
+ = case lookupUFM callishMachOps name of
+ Nothing -> fail ("unknown primitive " ++ unpackFS name)
+ Just p -> return $ do
+ results <- sequence results_code
+ args <- sequence args_code
+ code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
+
doStore :: MachRep -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
doStore rep addr_code val_code
= do addr <- addr_code
initEnv :: Env
initEnv = listToUFM [
( FSLIT("SIZEOF_StgHeader"),
- CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ),
+ Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
( FSLIT("SIZEOF_StgInfoTable"),
- CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
+ Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
]
-parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags hmods filename = do
+parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags filename = do
showPass dflags "ParseCmm"
buf <- hGetStringBuffer filename
let
case unP cmmParse init_state of
PFailed span err -> do printError span err; return Nothing
POk _ code -> do
- cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
+ cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
return (Just cmm)
where
projects / ghc-hetmet.git / blobdiff