#ifdef GHCI
, hscGetModuleExports
, hscTcRnLookupRdrName
- , hscStmt, hscTcExpr, hscImport, hscKcType
+ , hscStmt, hscStmtWithLocation
+ , hscTcExpr, hscImport, hscKcType
, hscCompileCoreExpr
#endif
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
-import Cmm ( Cmm )
+import OldCmm ( Cmm )
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmCPS
-import CmmCPSZ
import CmmInfo
import OptimizationFuel ( initOptFuelState )
import CmmCvt
-import CmmTx
-import CmmContFlowOpt
+import CmmContFlowOpt ( runCmmContFlowOpts )
import CodeOutput
import NameEnv ( emptyNameEnv )
import NameSet ( emptyNameSet )
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags
= do { eps_var <- newIORef initExternalPackageState
- ; us <- mkSplitUniqSupply 'r'
- ; nc_var <- newIORef (initNameCache us knownKeyNames)
- ; fc_var <- newIORef emptyUFM
+ ; us <- mkSplitUniqSupply 'r'
+ ; nc_var <- newIORef (initNameCache us knownKeyNames)
+ ; fc_var <- newIORef emptyUFM
; mlc_var <- newIORef emptyModuleEnv
; optFuel <- initOptFuelState
; return (HscEnv { hsc_dflags = dflags,
hsc_type_env_var = Nothing } ) }
-knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
- -- where templateHaskellNames are defined
-knownKeyNames = map getName wiredInThings
- ++ basicKnownKeyNames
+knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
+ -- where templateHaskellNames are defined
+knownKeyNames
+ = map getName wiredInThings
+ ++ basicKnownKeyNames
#ifdef GHCI
- ++ templateHaskellNames
+ ++ templateHaskellNames
#endif
-- -----------------------------------------------------------------------------
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
- -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
+ cmms <- optionallyConvertAndOrCPS hsc_env cmms
-- unless certain dflags are on, the identity function
------------------ Code output -----------------------
rawcmms <- cmmToRawCmm cmms
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
(pprCmms prog)
- ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
+ ; prog <- return $ map runCmmContFlowOpts prog
-- Control flow optimisation
-- We are building a single SRT for the entire module, so
-- we must thread it through all the procedures as we cps-convert them.
; us <- mkSplitUniqSupply 'S'
; let topSRT = initUs_ us emptySRT
- ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
+ ; (topSRT, prog) <- foldM (protoCmmCPS hsc_env) (topSRT, []) prog
-- The main CPS conversion
- ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
+ ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog)
-- Control flow optimisation, again
; let prog' = map cmmOfZgraph prog
cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
then mapM (testCmmConversion hsc_env) cmms
else return cmms
- --------- Optionally convert to CPS (MDA) -----------
- cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
- dopt Opt_RunCPS dflags
- then cmmCPS dflags cmms
- else return cmms
return cmms
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
--continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
us <- mkSplitUniqSupply 'C'
- let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
- let cvtm = do g <- cmmToZgraph cmm
- return $ cfopts g
+ let cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm
let zgraph = initUs_ us cvtm
us <- mkSplitUniqSupply 'S'
let topSRT = initUs_ us emptySRT
- (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
+ (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) zgraph
let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
showPass dflags "Convert from Z back to Cmm"
- let cvt = cmmOfZgraph $ cfopts $ chosen_graph
+ let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
return cvt
-> String -- The statement
-> IO (Maybe ([Id], HValue))
-- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
-hscStmt hsc_env stmt = runHsc hsc_env $ do
- maybe_stmt <- hscParseStmt stmt
+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
+
+hscStmtWithLocation -- Compile a stmt all the way to an HValue, but don't run it
+ :: HscEnv
+ -> String -- The statement
+ -> String -- the source
+ -> Int -- ^ starting line
+ -> IO (Maybe ([Id], HValue))
+ -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
+hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
+ maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do -- The real stuff
hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
hscParseStmt = hscParseThing parseStmt
+hscParseStmtWithLocation :: String -> Int
+ -> String -> Hsc (Maybe (LStmt RdrName))
+hscParseStmtWithLocation source linenumber stmt =
+ hscParseThingWithLocation source linenumber parseStmt stmt
+
hscParseType :: String -> Hsc (LHsType RdrName)
hscParseType = hscParseThing parseType
#endif
hscParseIdentifier hsc_env str = runHsc hsc_env $
hscParseThing parseIdentifier str
-
hscParseThing :: (Outputable thing)
=> Lexer.P thing
-> String
-> Hsc thing
+hscParseThing = hscParseThingWithLocation "<interactive>" 1
-hscParseThing parser str
+hscParseThingWithLocation :: (Outputable thing)
+ => String -> Int
+ -> Lexer.P thing
+ -> String
+ -> Hsc thing
+hscParseThingWithLocation source linenumber parser str
= {-# SCC "Parser" #-} do
dflags <- getDynFlags
liftIO $ showPass dflags "Parser"
-
+
let buf = stringToStringBuffer str
- loc = mkSrcLoc (fsLit "<interactive>") 1 1
+ loc = mkSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
mg_insts = [],
mg_fam_insts = [],
mg_rules = [],
+ mg_vect_decls = [],
mg_binds = binds,
mg_foreign = NoStubs,
mg_warns = NoWarnings,
projects / ghc-hetmet.git / blobdiff