module E.Main(processInitialHo,processDecls,compileWholeProgram,dumpRules) where
import Control.Exception
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import System.Mem
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List
import DataConstructors
import Doc.PPrint
import E.Annotate(annotateDs,annotateCombs,annotateProgram)
import E.E
import E.Eta
import E.FromHs
import E.Inline
import E.LambdaLift
import E.LetFloat
import E.Lint
import E.Program
import E.Rules
import E.Traverse
import E.TypeAnalysis
import E.TypeCheck
import E.Values
import E.WorkerWrapper
import FrontEnd.Class(augmentClassHierarchy)
import FrontEnd.HsSyn
import FrontEnd.KindInfer
import FrontEnd.Tc.Module
import FrontEnd.Warning
import Grin.Show(render)
import Ho.Build
import Ho.Collected
import Info.Types
import Name.Id
import Name.Name
import Options
import Support.CanType(getType)
import Support.FreeVars
import Support.TempDir
import Support.Transform
import Util.Gen
import Util.Graph
import Util.Progress
import Util.SetLike as S
import qualified E.CPR
import qualified E.Demand as Demand(analyzeProgram)
import qualified E.SSimplify as SS
import qualified FlagDump as FD
import qualified FlagOpts as FO
import qualified Info.Info as Info
import qualified Stats
lamann _ nfo = return nfo
letann e nfo = return (annotateArity e nfo)
idann ps i nfo = return (props ps i nfo) where
props :: IdMap Properties -> Id -> Info.Info -> Info.Info
props ps i = case mlookup i ps of
Just ps -> modifyProperties (mappend ps)
Nothing -> id
processInitialHo ::
CollectedHo
-> Ho
-> IO CollectedHo
processInitialHo accumho aho = withStackStatus "processInitialHo" $ do
let Rules rm = hoRules $ hoBuild aho
newTVrs = fsts $ hoEs (hoBuild aho)
(_,orphans) = spartition (\ (k,_) -> k `elem` map tvrIdent newTVrs) rm
let fakeEntry = emptyComb { combRules = map ruleUpdate . concat $ values orphans }
combs = fakeEntry:[combRules_s (map ruleUpdate $ findWithDefault [] (tvrIdent t) rm) (bindComb (t,e)) | (t,e) <- hoEs (hoBuild aho) ]
let choCombinators' = fromList [ (combIdent c,c) | c <- runIdentity $ annotateCombs (choVarMap accumho) (\_ -> return) letann lamann combs]
nrules = map ruleUpdate . combRules $ findWithDefault emptyComb emptyId choCombinators'
reRule :: Comb -> Comb
reRule comb = combRules_u f comb where
f rs = Data.List.union rs [ x | x <- nrules, ruleHead x == combHead comb]
let choCombs = sfilter (\(k,_) -> k /= emptyId) choCombinators'
return $ updateChoHo mempty {
choExternalNames = choExternalNames accumho `mappend` (fromList . map tvrIdent $ newTVrs),
choCombinators = choCombs `mappend` fmap reRule (choCombinators accumho),
choHoMap = Map.singleton (hoModuleGroup aho) aho `mappend` choHoMap accumho
}
processDecls ::
CollectedHo
-> Ho
-> TiData
-> IO (CollectedHo,Ho)
processDecls cho ho' tiData = withStackStatus "processDecls" $ do
let ho = choHo cho
decls = tiDataDecls tiData ++ [ x | x@HsForeignExport {} <- originalDecls ]
originalDecls = concat [ hsModuleDecls m | (_,m) <- tiDataModules tiData ]
let derives = (collectDeriving originalDecls)
let dataTable = toDataTable (getConstructorKinds (hoKinds $ hoTcInfo ho'))
(tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)
classInstances = deriveClasses (choCombinators cho) fullDataTable derives
fullDataTable = dataTable `mappend` hoDataTable (hoBuild ho)
wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
wdump FD.Derived $ do
mapM_ print derives
mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) classInstances
let prog = program {
progDataTable = fullDataTable,
progExternalNames = choExternalNames cho,
progModule = head (fsts $ tiDataModules tiData)
}
let allAssumps = (tiAllAssumptions tiData `mappend` hoAssumps (hoTcInfo ho))
theProps = fromList [ (toId x,y) | (x,y) <- Map.toList $ tiProps tiData]
ds' <- convertDecls tiData theProps
(hoClassHierarchy $ hoTcInfo ho') allAssumps fullDataTable decls
processIOErrors
let ds = classInstances ++ [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
let augmentedClassHierarchy = hoClassHierarchy (hoTcInfo ho) `augmentClassHierarchy` hoClassHierarchy (hoTcInfo ho')
instanceRules <- createInstanceRules fullDataTable augmentedClassHierarchy (ds `mappend` hoEs (hoBuild ho))
userRules <- convertRules (progModule prog) tiData (hoClassHierarchy $ hoTcInfo ho') allAssumps fullDataTable decls
(nds,specializeRules) <- procAllSpecs fullDataTable (tiCheckedRules tiData) ds
ds <- return $ ds ++ nds
wdump FD.CoreInitial $
mapM_ (\(v,lc) -> printCheckName'' fullDataTable v lc) ds
ds <- annotateDs mempty (\_ nfo -> return nfo) (\_ nfo -> return nfo) (\_ nfo -> return nfo) ds
wdump FD.CoreInitial $
mapM_ (\(v,lc) -> printCheckName'' fullDataTable v lc) ds
let rules@(Rules rules') = instanceRules `mappend` userRules `mappend` specializeRules
dumpRules rules
let seasoning = freeVars [ rs | (k,rs) <- toList rules', k `notMember` defined ] `intersection` defined
defined = fromList $ map (tvrIdent . fst) ds :: IdSet
prog <- return prog { progSeasoning = seasoning }
Identity prog <- return $ programMapDs (\ (t,e) -> return (shouldBeExported (getExports $ hoTcInfo ho') t,e)) $ atomizeApps False (programSetDs ds prog)
let addRule c = case mlookup (combIdent c) rules' of
Nothing -> c
Just rs -> combRules_u (map ruleUpdate . Data.List.union rs) c
prog <- return $ progCombinators_u (map addRule) prog
cho <- return $ updateChoHo $ choCombinators_u (fmap addRule) cho
prog <- return $ runIdentity $ annotateProgram (choVarMap cho) (idann theProps) letann lamann prog
lintCheckProgram (putErrLn "LintPostProcess") prog
let entryPoints = fromList . execWriter $ programMapDs_ (\ (t,_) -> when
(getProperty prop_EXPORTED t || getProperty prop_INSTANCE t || getProperty prop_SPECIALIZATION t) (tell [tvrIdent t])) prog
prog <- return $ prog { progEntry = entryPoints `mappend` progSeasoning prog }
lintCheckProgram (putErrLn "InitialLint") prog
prog <- programPrune prog
let sopt = SS.cacheSimpOpts SS.emptySimplifyOpts {
SS.so_boundVars = choCombinators cho,
SS.so_forwardVars = progSeasoning prog
}
let tparms = transformParms {
transformPass = "PreInit",
transformDumpProgress = verbose
}
prog <- transformProgram tparms {
transformCategory = "FloatInward",
transformOperation = programFloatInward
} prog
putProgress "<"
pr_r <- progressIONew (length $ programDecomposedDs prog) 25 '.'
let fint mprog = do
let names = pprint [ n | (n,_) <- programDs mprog]
withStackStatus ("fint: " ++ names) $ do
when coreMini $ putErrLn ("----\n" ++ names)
let tparms = transformParms { transformPass = "Init", transformDumpProgress = coreMini }
lintCheckProgram onerrNone mprog
mprog <- evaluate $ etaAnnotateProgram mprog
lintCheckProgram onerrNone mprog
mprog <- simplifyProgram sopt "Init-One" coreMini mprog
mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "SimpleRecursive"
, transformOperation = return . staticArgumentTransform } mprog
mprog <- transformProgram tparms { transformCategory = "FloatOutward", transformOperation = floatOutward } mprog
mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformPass = "PreInit"
, transformOperation = typeAnalyze True } mprog
mprog <- transformProgram tparms { transformCategory = "FloatOutward", transformOperation = floatOutward } mprog
mprog <- simplifyProgram sopt "Init-Two-FloatOutCleanup" coreMini mprog
mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformOperation = typeAnalyze True } mprog
mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog
mprog <- Demand.analyzeProgram mprog
lintCheckProgram onerrNone mprog
mprog <- simplifyProgram sopt "Init-Three-AfterDemand" False mprog
when miniCorePass $ printProgram mprog
when miniCoreSteps $ Stats.printLStat (optStatLevel options) ("InitialOptimize:" ++ names) (progStats mprog)
wdump FD.Progress $ let SubProgram isRec = progType mprog in progressIOSteps pr_r (if isRec then "*" else ".")
return mprog
lintCheckProgram onerrNone prog
prog <- programMapProgGroups mempty fint prog
wdump FD.Stats $
Stats.printLStat (optStatLevel options) "Initial Pass Stats" (progStats prog)
lintCheckProgram onerrNone prog
prog <- etaExpandProg "Init-Big-One" prog { progStats = mempty }
prog <- transformProgram tparms {
transformPass = "Init-Big-One",
transformCategory = "FloatInward",
transformOperation = programFloatInward
} prog
prog <- Demand.analyzeProgram prog
prog <- simplifyProgram' sopt "Init-Big-One" verbose (IterateMax 4) prog
wdump FD.Stats $
Stats.printLStat (optStatLevel options) "Init-Big-One Stats" (progStats prog)
pr_r <- progressIONew (length $ programDecomposedCombs prog) 25 '.'
let optWW mprog = do
let names = pprint [ n | (n,_) <- programDs mprog]
liftIO $ when coreMini $ putErrLn ("----\n" ++ names)
smap <- get
let tparms = transformParms { transformPass = "OptWW", transformDumpProgress = coreMini }
sopt = SS.cacheSimpOpts SS.emptySimplifyOpts {
SS.so_boundVars = smap,
SS.so_forwardVars = progSeasoning mprog
}
mprog <- simplifyProgram sopt "Simplify-One" coreMini mprog
mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog
mprog <- Demand.analyzeProgram mprog
mprog <- simplifyProgram sopt "Simplify-Two" coreMini mprog
mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog
mprog <- Demand.analyzeProgram mprog
mprog <- return $ E.CPR.cprAnalyzeProgram mprog
mprog' <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "WorkWrap", transformOperation = return . workWrapProgram } mprog
let wws = length (programDs mprog') length (programDs mprog)
mprog <- return mprog'
mprog <- simplifyProgram sopt "Simplify-Three" coreMini mprog
mprog <- return $ etaAnnotateProgram mprog
mprog <- Demand.analyzeProgram mprog
mprog <- return $ E.CPR.cprAnalyzeProgram mprog
put $ fromList [ (combIdent c,c) | c <- progCombinators mprog] `S.union` smap
liftIO $ wdump FD.Progress $ let SubProgram isRec = progType mprog in progressIOSteps pr_r (if wws > 0 then "w" else if isRec then "*" else ".")
return mprog
prog <- evalStateT (programMapProgGroups mempty optWW prog { progStats = mempty }) (SS.so_boundVars sopt)
putProgressLn ">"
wdump FD.Stats $
Stats.printLStat (optStatLevel options) "MainPass Stats" (progStats prog)
processIOErrors
lintCheckProgram (putErrLn "After the workwrap/CPR") prog
prog <- programPrune prog
lintCheckProgram (putErrLn "After the Opimization") prog
wdump FD.Core $ printProgram prog
let newHoBuild = (hoBuild ho') {
hoDataTable = dataTable,
hoEs = programDs prog,
hoRules = hoRules (hoBuild ho') `mappend` rules
}
newMap = fmap (\c -> Just (EVar $ combHead c)) $ progCombMap prog
return (updateChoHo $ mempty {
choHoMap = Map.singleton (hoModuleGroup ho') ho' { hoBuild = newHoBuild},
choCombinators = fromList $ [ (combIdent c,c) | c <- progCombinators prog ],
choExternalNames = idMapToIdSet newMap
} `mappend` cho,ho' { hoBuild = newHoBuild })
coreMini = dump FD.CoreMini
corePass = dump FD.CorePass
coreSteps = dump FD.CoreSteps
miniCorePass = coreMini && corePass
miniCoreSteps = coreMini && coreSteps
dumpRules rules = do
wdump FD.Rules $ putStrLn " ---- user rules ---- " >> printRules RuleUser rules
wdump FD.Rules $ putStrLn " ---- user catalysts ---- " >> printRules RuleCatalyst rules
wdump FD.RulesSpec $ putStrLn " ---- specializations ---- " >> printRules RuleSpecialization rules
programPruneUnreachable :: Program -> Program
programPruneUnreachable prog = progCombinators_s ds' prog where
ds' = reachableFrom combIdent freeVars (progCombinators prog) (toList $ progEntry prog)
programPrune :: Program -> IO Program
programPrune prog = transformProgram transformParms { transformCategory = "PruneUnreachable"
, transformDumpProgress = miniCorePass
, transformOperation = evaluate . programPruneUnreachable } prog
etaExpandProg :: String -> Program -> IO Program
etaExpandProg pass prog = do
let f prog = prog' { progStats = progStats prog `mappend` stats } where
(prog',stats) = Stats.runStatM $ etaExpandProgram prog
transformProgram transformParms { transformPass = pass, transformCategory = "EtaExpansion"
, transformDumpProgress = miniCorePass, transformOperation = evaluate . f } prog
getExports ho = Set.fromList $ map toId $ concat $ Map.elems (hoExports ho)
shouldBeExported exports tvr
| tvrIdent tvr `Set.member` exports || getProperty prop_SRCLOC_ANNOTATE_FUN tvr = setProperty prop_EXPORTED tvr
| otherwise = tvr
transTypeAnalyze = transformParms { transformCategory = "typeAnalyze", transformOperation = typeAnalyze True }
simplifyProgram sopt name dodump prog = liftIO $ do
let istat = progStats prog
let g prog = do
let nprog = SS.programPruneOccurance prog
when (corePass && dodump) $ do
putStrLn "-- After Occurance Analysis"
printProgram nprog
lintCheckProgram (putErrLn "AfterOccurance") nprog
return $ SS.programSSimplify sopt nprog
prog <- transformProgram transformParms { transformCategory = "Simplify"
, transformPass = name
, transformIterate = IterateDone
, transformDumpProgress = dodump
, transformOperation = g } prog { progStats = mempty }
when (dodump && (dump FD.Progress || coreSteps)) $
Stats.printLStat (optStatLevel options) ("Total: " ++ name) (progStats prog)
return prog { progStats = progStats prog `mappend` istat }
simplifyProgram' sopt name dodump iterate prog = do
let istat = progStats prog
let g = return . SS.programSSimplify sopt . SS.programPruneOccurance
prog <- transformProgram transformParms { transformCategory = "Simplify"
, transformPass = name
, transformIterate = iterate
, transformDumpProgress = dodump
, transformOperation = g } prog { progStats = mempty }
when (dodump && (dump FD.Progress || coreSteps)) $ Stats.printLStat (optStatLevel options) ("Total: " ++ name) (progStats prog)
return prog { progStats = progStats prog `mappend` istat }
compileWholeProgram prog = do
performGC
when verbose $ do
Stats.print "PassStats" Stats.theStats
Stats.clear Stats.theStats
esmap <- programEsMap prog
let mainFunc = parseName Val (maybe "Main.main" snd (optMainFunc options))
dataTable = progDataTable prog
ffiExportNames = [ tv | tv <- map combHead $ progCombinators prog, name <- tvrName tv, "FE@" `isPrefixOf` show name ]
(main,mainv) <- getMainFunction dataTable mainFunc esmap
prog <- return $ programUpdate prog {
progMain = tvrIdent main,
progEntry = fromList $ map tvrIdent (main:ffiExportNames),
progCombinators = emptyComb { combHead = main, combBody = mainv }:map (unsetProperty prop_EXPORTED) (progCombinators prog)
}
prog <- transformProgram transformParms {
transformCategory = "PruneUnreachable",
transformOperation = evaluate . programPruneUnreachable
} prog
prog <- if (fopts FO.TypeAnalysis) then do
transformProgram transformParms { transformCategory = "TypeAnalyzeMethods",
transformOperation = typeAnalyze False,
transformDumpProgress = dump FD.Progress }
prog
else return prog
when verbose $ do
putStrLn "Type analyzed methods"
flip mapM_ (sortUnder (show . fst) (programDs prog)) $ \ (t,e) -> do
let (_,ts) = fromLam e
ts' = takeWhile (sortKindLike . getType) ts
when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++
concat [ "(" ++ show (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
lintCheckProgram onerrNone prog
prog <- programPrune prog
cmethods <- do
let es' = concatMap expandPlaceholder (progCombinators prog)
es' <- return [ combBody_u floatInward e | e <- es' ]
wdump FD.Class $ do
sequence_ [ printCheckName'' dataTable (combHead x) (combBody x) | x <- es']
return es'
prog <- evaluate $ progCombinators_s ([ p | p <- progCombinators prog,
combHead p `notElem` map combHead cmethods] ++ cmethods) prog
prog <- annotateProgram mempty (\_ nfo -> return $ unsetProperty prop_INSTANCE nfo)
letann (\_ nfo -> return nfo) prog
if not (fopts FO.GlobalOptimize) then do
prog <- programPrune prog
wdump FD.CoreBeforelift $ printProgram prog
prog <- transformProgram transformParms {
transformCategory = "LambdaLift",
transformDumpProgress = dump FD.Progress,
transformOperation = lambdaLift } prog
wdump FD.CoreAfterlift $ printProgram prog
prog <- return $ atomizeApps True prog
wdump FD.CoreMangled $ dumpCore "mangled" prog
return prog
else do
prog <- transformProgram transTypeAnalyze {
transformPass = "Main-AfterMethod",
transformDumpProgress = verbose } prog
prog <- simplifyProgram SS.emptySimplifyOpts "Main-One" verbose prog
prog <- etaExpandProg "Main-AfterOne" prog
wdump FD.CorePass $ dumpCore "before-TypeAnalyze-Main-AfterSimp" prog
prog <- transformProgram transTypeAnalyze {
transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog
prog <- simplifyProgram SS.emptySimplifyOpts "Main-Two" verbose prog
prog <- return $ runIdentity $ annotateProgram mempty (\_ nfo -> return $
modifyProperties (flip (foldr S.delete) [prop_HASRULE,prop_WORKER]) nfo)
letann (\_ -> return) prog
prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True }
"SuperSimplify no rules" verbose prog
prog <- transformProgram transformParms {
transformCategory = "BoxifyProgram",
transformDumpProgress = dump FD.Progress,
transformOperation = boxifyProgram } prog
prog <- programPrune prog
prog <- Demand.analyzeProgram prog
prog <- return $ E.CPR.cprAnalyzeProgram prog
prog <- transformProgram transformParms {
transformCategory = "Boxy WorkWrap",
transformDumpProgress = dump FD.Progress,
transformOperation = evaluate . workWrapProgram } prog
prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True }
"SuperSimplify after Boxy WorkWrap" verbose prog
prog <- return $ runIdentity $ programMapBodies (return . cleanupE) prog
wdump FD.CoreBeforelift $ dumpCore "before-lift" prog
prog <- transformProgram transformParms {
transformCategory = "LambdaLift",
transformDumpProgress = dump FD.Progress,
transformOperation = lambdaLift } prog
wdump FD.CoreAfterlift $ dumpCore "after-lift" prog
finalStats <- Stats.new
lintCheckProgram (putErrLn "LintPostLifting") prog
prog <- Demand.analyzeProgram prog
prog <- return $ E.CPR.cprAnalyzeProgram prog
prog <- simplifyProgram SS.emptySimplifyOpts {
SS.so_postLift = True, SS.so_finalPhase = True } "PostLiftSimplify" verbose prog
when verbose $ do
Stats.print "PassStats" Stats.theStats
Stats.clear Stats.theStats
prog <- return $ atomizeApps True prog
wdump FD.CoreMangled $ dumpCore "mangled" prog
return prog
boxifyProgram :: Program -> IO Program
boxifyProgram prog = ans where
ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog)
f (t,e) = do
e <- return $ runReader (g e) Set.empty
tt <- return $ runReader (boxify (tvrType t)) Set.empty
return (t {tvrType = tt},e)
_tv t = t { tvrType = boxify (tvrType t) }
g e = do
emapEG g (boxify) e
boxify (from_unsafeCoerce -> Just (e,t)) = do
t' <- boxify t
e' <- boxify e
case typesCompatable t' (getType e') of
Just () -> return e
_ -> return $ prim_unsafeCoerce e' t'
boxify (EPi t e) = local (Set.insert (tvrIdent t)) $ do
nt <- boxify $ tvrType t
ne <- boxify e
return $ EPi t { tvrType = nt } ne
boxify v@(EVar vr) | canBeBox v = do
s <- ask
if tvrIdent vr `Set.member` s then return v else return $ mktBox (tvrType vr)
boxify (ELit lc) = do
na <- mapM boxify (litArgs lc)
return $ ELit lc { litArgs = na }
boxify (EAp a b) = liftM2 eAp (boxify a) (boxify b)
boxify s@ESort {} = return s
boxify x = error $ "boxify: " ++ show x
cleanupE :: E -> E
cleanupE e = runIdentity (f e) where
f (ELam t@TVr { tvrIdent = v } e) | v /= emptyId, v `notMember` freeIds e = f (ELam t { tvrIdent = emptyId } e)
f (EPi t@TVr { tvrIdent = v } e) | v /= emptyId, v `notMember` freeIds e = f (EPi t { tvrIdent = emptyId } e)
f ec@ECase { eCaseBind = t@TVr { tvrIdent = v } } | v /= emptyId, v `notMember` (freeVars (caseBodies ec)::IdSet) = f ec { eCaseBind = t { tvrIdent = emptyId } }
f e = emapEG f f e