[move core compilation code to E.Main, out of Main
John Meacham <john@repetae.net>**20100301210817
 Ignore-this: 2030663cfb9500ec6ee2f23e9634e4c1
] hunk ./Makefile.am 42
-	src/Support/IniParse.hs src/E/Lint.hs src/Util/Progress.hs src/Grin/StorageAnalysis.hs src/Util/YAML.hs src/Grin/Main.hs
+	src/Support/IniParse.hs src/E/Lint.hs src/Util/Progress.hs src/Grin/StorageAnalysis.hs src/Util/YAML.hs src/Grin/Main.hs \
+        src/E/Main.hs
addfile ./src/E/Main.hs
hunk ./src/E/Main.hs 1
+-- this file contains the main driver for the core->core optimizations
+
+module E.Main(processInitialHo,processDecls,compileWholeProgram,dumpRules) where
+
+import Control.Exception
+import Control.Monad.Identity
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.Monoid
+import Prelude hiding(putStrLn, putStr,print)
+import System.Mem
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified List
+
+import CharIO
+import DataConstructors
+import Doc.PPrint
+import E.Annotate(annotateDs,annotateCombs,annotateProgram)
+import E.Diff
+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.Subst(subst)
+import E.Traverse
+import E.TypeAnalysis
+import E.TypeCheck
+import E.WorkerWrapper
+import FrontEnd.HsSyn
+import FrontEnd.KindInfer
+import FrontEnd.Tc.Module
+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.Transform
+import Util.Gen hiding(putErrLn,putErr,putErrDie)
+import Util.Graph
+import Util.Progress
+import Util.SetLike as S
+import Data.List
+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       -- ^ current accumulated ho
+    -> Ho             -- ^ new ho, freshly read from file
+    -> IO CollectedHo -- ^ final combined ho data.
+processInitialHo accumho aho = do
+    let Rules rm = hoRules $ hoBuild aho
+        newTVrs = fsts $ hoEs (hoBuild aho)
+        (_,orphans) = mpartitionWithKey (\k _ -> k `elem` map tvrIdent newTVrs) rm
+
+    let fakeEntry = emptyComb { combRules = map ruleUpdate . concat $ melems orphans }
+        combs =  fakeEntry:[combRules_s (map ruleUpdate $ mfindWithDefault [] (tvrIdent t) rm) (bindComb (t,e))  | (t,e) <- hoEs (hoBuild aho) ]
+
+    -- extract new combinators and processed rules
+    let choCombinators' = fromList [ (combIdent c,c) | c <- runIdentity $ annotateCombs (choVarMap accumho) (\_ -> return) letann lamann combs]
+        nrules = map ruleUpdate . combRules $ mfindWithDefault emptyComb emptyId choCombinators'
+        reRule :: Comb -> Comb
+        reRule comb = combRules_u f comb where
+            f rs = List.union  rs [ x | x <- nrules, ruleHead x == combHead comb]
+
+    let finalVarMap = mappend (fromList [(tvrIdent tvr,Just $ EVar tvr) | tvr <- map combHead $ melems choCombs ]) (choVarMap accumho)
+        choCombs = mfilterWithKey (\k _ -> k /= emptyId) choCombinators'
+    return $ updateChoHo mempty {
+        choVarMap = finalVarMap,
+        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             -- ^ Collected ho
+    -> Ho                   -- ^ preliminary haskell object  data
+    -> TiData               -- ^ front end output
+    -> IO (CollectedHo,Ho)  -- ^ (new accumulated ho, final ho for this modules)
+processDecls cho ho' tiData = do
+    -- some useful values
+    let ho = choHo cho
+        -- XXX typechecker drops foreign exports!
+        decls  = tiDataDecls tiData ++ [ x | x@HsForeignExport {} <- originalDecls ]
+        originalDecls =  concat [ hsModuleDecls  m | (_,m) <- tiDataModules tiData ]
+
+    -- build datatables
+    let dataTable = toDataTable (getConstructorKinds (hoKinds $ hoTcInfo ho')) (tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)
+        classInstances = deriveClasses (choCombinators cho) dataTable
+        fullDataTable = dataTable `mappend` hoDataTable (hoBuild ho)
+    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
+
+    wdump FD.Derived $
+        mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) classInstances
+    -- initial program
+    let prog = program {
+            progDataTable = fullDataTable,
+            progExternalNames = choExternalNames cho,
+            progModule = head (fsts $ tiDataModules tiData)
+            }
+
+    -- Convert Haskell decls to E
+    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
+    let ds = [ (v,e) | (v,e) <- classInstances ] ++  [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
+ --   sequence_ [lintCheckE onerrNone fullDataTable v e | (_,v,e) <- ds ]
+
+    -- Build rules from instances, specializations, and user specified rules and catalysts
+    instanceRules <- createInstanceRules fullDataTable (hoClassHierarchy $ hoTcInfo ho')  (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) <- massocs rules', k `notMember` defined ] `intersection` defined
+        defined = fromList $ map (tvrIdent . fst) ds :: IdSet
+
+    -- our initial program
+    prog <- return prog { progSeasoning = seasoning }
+    Identity prog <- return $ programMapDs (\ (t,e) -> return (shouldBeExported (getExports $ hoTcInfo ho') t,e)) $ atomizeApps False (programSetDs ds prog)
+
+    -- now we must attach rules to the existing chos, as well as the current ones
+    let addRule c = case mlookup (combIdent c) rules' of
+            Nothing -> c
+            Just rs -> combRules_u (map ruleUpdate . List.union rs) c
+    prog <- return $ progCombinators_u (map addRule) prog
+    cho <- return $ choCombinators_u (fmap addRule) cho
+
+    -- Here we substitute in all the original types, with rules and properties defined in the current module included
+    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
+
+
+    -- initial pass, performs
+    -- eta expansion of definitons
+    -- simplify
+    -- type analysis
+    -- floating outward
+    -- simplify
+    -- floating inward
+
+    let sopt = SS.cacheSimpOpts SS.emptySimplifyOpts {
+            SS.so_boundVars = choCombinators cho,
+            SS.so_forwardVars = progSeasoning prog
+            }
+    let tparms = transformParms {
+            transformPass = "PreInit",
+            transformDumpProgress = verbose
+            }
+
+    -- quick float inward pass to inline once used functions and prune unused ones
+    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]
+        when coreMini $ putErrLn ("----\n" ++ names)
+        let tparms = transformParms { transformPass = "Init", transformDumpProgress = coreMini }
+
+
+        mprog <- evaluate $ etaAnnotateProgram mprog
+
+        mprog <- simplifyProgram sopt "Init-One" coreMini mprog
+
+        -- | this catches more static arguments if we wait until after the initial normalizing simplification pass
+        mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "SimpleRecursive"
+                                         , transformOperation = return . staticArgumentTransform } mprog
+
+        mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformPass = "PreInit"
+                                         , transformOperation = typeAnalyze True } mprog
+
+        mprog <- transformProgram tparms { transformCategory = "FloatOutward", transformOperation = floatOutward } mprog
+        -- perform another supersimplify in order to substitute the once used
+        -- variables back in and replace the variable of case of variables with
+        -- the default binding of the case statement.
+
+        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 -- mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) (programDs mprog)
+        when miniCoreSteps $ Stats.printLStat (optStatLevel options) ("InitialOptimize:" ++ names) (progStats mprog)
+        --wdump FD.Progress $ let SubProgram rec = progType mprog in  putErr (if rec then "*" else ".")
+        wdump FD.Progress $ let SubProgram isRec = progType mprog in  progressIOSteps pr_r (if isRec then "*" else ".")
+        return mprog
+    lintCheckProgram onerrNone prog
+    --putProgressLn "Initial optimization pass"
+
+    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 $ programDecomposedDs prog) 25 '.'
+
+    -- This is the main function that optimizes the routines before writing them out
+    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)
+--        liftIO $ wdump FD.Progress $ putErr (replicate wws 'w')
+        mprog <- return mprog'
+
+        mprog <- simplifyProgram sopt "Simplify-Three" 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 = "WorkWrap2", transformOperation = return . workWrapProgram } mprog
+        --mprog <- simplifyProgram sopt "Simplify-Four" coreMini mprog
+
+
+        -- annotate our bindings for further passes
+        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 rec = progType mprog in  putErr (if rec then "*" else ".")
+        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)
+
+    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,
+        choVarMap = 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
+            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 }
+
+{-
+simplifyProgramPStat sopt name dodump prog = do
+    let istat = progStats prog
+    let g =  SS.programSSimplifyPStat sopt { SS.so_dataTable = progDataTable prog } . SS.programPruneOccurance
+    prog <- transformProgram ("PS:" ++ name) IterateDone dodump g prog  { progStats = mempty }
+    when ((dodump && dump FD.Progress) || dump FD.CoreSteps) $ Stats.printStat ("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 }
+
+
+{-# NOINLINE compileWholeProgram #-}
+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_ (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
+    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog
+    prog <- simplifyProgram SS.emptySimplifyOpts "Main-Two" verbose prog
+
+    -- run optimization again with no rules enabled
+    prog <- return $ runIdentity $ annotateProgram mempty (\_ nfo -> return $ modifyProperties (flip (foldr S.delete) [prop_HASRULE,prop_WORKER]) nfo) letann (\_ -> return) prog
+    --prog <- transformProgram "float inward" DontIterate True programFloatInward prog
+
+    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True } "SuperSimplify no rules" verbose prog
+
+    -- We should float inward right before lambda lifting so that when a case statement is lifted out, it takes any local definitions with it.
+--    prog <- transformProgram transformParms {
+--        transformCategory = "FloatInward",
+--        transformDumpProgress = dump FD.Progress,
+--        transformOperation = programFloatInward
+--        } prog
+    -- perform lambda lifting
+--    prog <- denewtypeProgram 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
+
+    -- final optimization pass to clean up lambda lifting droppings
+--    prog <- flip programMapBodies prog $ \ e -> do
+--        let cm stats e = do
+--            let sopt = mempty {  SS.so_dataTable = dataTable }
+--            let (stat, e') = SS.simplifyE sopt e
+--            Stats.tickStat stats stat
+--            return e'
+--        doopt (mangle' Nothing dataTable) False finalStats "PostLambdaLift"  cm e
+--    wdump FD.Progress $ Stats.print "PostLifting" finalStats
+
+    lintCheckProgram (putErrLn "LintPostLifting") prog
+
+    wdump FD.Progress $ printEStats (programE 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
+--    prog <- programFloatInward 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
+
+
+-- | this gets rid of all type variables, replacing them with boxes that can hold any type.
+-- The program is still type-safe, but all polymorphism has been removed in favor of
+-- implicit coercion to a universal type in preparation for the grin transformation.
+
+boxifyProgram :: Program -> IO Program
+boxifyProgram prog = ans where
+    ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog)
+    f (t,e) = do
+        e <- g e
+        return (tv t,e)
+    tv t = t { tvrType = boxify (tvrType t) }
+    g e = do
+        emapEG g (return . boxify) e -- (\e -> do putStrLn ("box: " ++ pprint e) ; return $ boxify e) e
+    boxify t | Just e <- followAlias (progDataTable prog) t = boxify e
+    boxify (EPi t e) = EPi t { tvrType = boxify (tvrType t) } (boxify e)
+    boxify v@EVar {} | canBeBox v = mktBox (getType v)
+    boxify (ELit lc) = ELit lc { litArgs = map boxify (litArgs lc) }
+--    boxify v@(EAp _ _) | canBeBox v = mktBox (getType v)
+    boxify (EAp (ELam t b) e) = boxify (subst t e b)
+ --   boxify (EAp a b) = EAp (boxify a) b -- TODO there should be no applications at the type level by now (boxify b)
+    boxify (EAp a b) = EAp (boxify a) (boxify b)
+    boxify s@ESort {} = s
+    boxify x = error $ "boxify: " ++ show x
+
+-- | get rid of unused bindings
+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
+
+
hunk ./src/Main.hs 5
-import Control.Monad.State
-import Control.Monad.Writer
hunk ./src/Main.hs 7
-import System.Mem
hunk ./src/Main.hs 8
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified List
hunk ./src/Main.hs 11
-import Doc.PPrint
-import E.Annotate(annotateDs,annotateCombs,annotateProgram)
-import E.Diff
-import E.E
-import E.Eta
-import E.FreeVars
-import E.FromHs
-import E.Inline
-import E.LambdaLift
-import E.LetFloat
-import E.Lint
-import E.Program
hunk ./src/Main.hs 12
-import E.Subst(subst)
-import E.Traverse
-import E.TypeAnalysis
-import E.TypeCheck
-import E.WorkerWrapper
+import E.Program
+import E.Type
+import FrontEnd.HsSyn(Module(..))
hunk ./src/Main.hs 16
-import FrontEnd.FrontEnd
-import FrontEnd.HsSyn
-import FrontEnd.KindInfer(getConstructorKinds)
-import GenUtil hiding(replicateM,putErrLn,putErr,putErrDie)
hunk ./src/Main.hs 21
-import Info.Types
-import Name.Id
+import E.Main
hunk ./src/Main.hs 24
-import Support.CanType(getType)
-import Support.FreeVars
-import Support.Transform
-import Util.Graph
-import Util.Progress
hunk ./src/Main.hs 25
-import Util.Util
hunk ./src/Main.hs 26
-import qualified E.CPR
-import qualified E.Demand as Demand(analyzeProgram)
-import qualified E.SSimplify as SS
hunk ./src/Main.hs 27
-import qualified FlagOpts as FO
-import qualified IO
-import qualified Info.Info as Info
hunk ./src/Main.hs 28
-import qualified Stats
hunk ./src/Main.hs 68
-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       -- ^ current accumulated ho
-    -> Ho             -- ^ new ho, freshly read from file
-    -> IO CollectedHo -- ^ final combined ho data.
-processInitialHo accumho aho = do
-    let Rules rm = hoRules $ hoBuild aho
-        newTVrs = fsts $ hoEs (hoBuild aho)
-        (_,orphans) = mpartitionWithKey (\k _ -> k `elem` map tvrIdent newTVrs) rm
-
-    let fakeEntry = emptyComb { combRules = map ruleUpdate . concat $ melems orphans }
-        combs =  fakeEntry:[combRules_s (map ruleUpdate $ mfindWithDefault [] (tvrIdent t) rm) (bindComb (t,e))  | (t,e) <- hoEs (hoBuild aho) ]
-
-    -- extract new combinators and processed rules
-    let choCombinators' = fromList [ (combIdent c,c) | c <- runIdentity $ annotateCombs (choVarMap accumho) (\_ -> return) letann lamann combs]
-        nrules = map ruleUpdate . combRules $ mfindWithDefault emptyComb emptyId choCombinators'
-        reRule :: Comb -> Comb
-        reRule comb = combRules_u f comb where
-            f rs = List.union  rs [ x | x <- nrules, ruleHead x == combHead comb]
-
-    let finalVarMap = mappend (fromList [(tvrIdent tvr,Just $ EVar tvr) | tvr <- map combHead $ melems choCombs ]) (choVarMap accumho)
-        choCombs = mfilterWithKey (\k _ -> k /= emptyId) choCombinators'
-    return $ updateChoHo mempty {
-        choVarMap = finalVarMap,
-        choExternalNames = choExternalNames accumho `mappend` (fromList . map tvrIdent $ newTVrs),
-        choCombinators = choCombs `mappend` fmap reRule (choCombinators accumho),
-        choHoMap = Map.singleton (hoModuleGroup aho) aho `mappend` choHoMap accumho
-        }
-
-
--- | this is called on parsed, typechecked haskell code to convert it to the internal representation
-
-coreMini = dump FD.CoreMini
-corePass = dump FD.CorePass
-coreSteps = dump FD.CoreSteps
-miniCorePass = coreMini && corePass
-miniCoreSteps = coreMini && coreSteps
-progressM c  = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr
-collectPassStats = verbose
-
-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
-
-processDecls ::
-    CollectedHo             -- ^ Collected ho
-    -> Ho                   -- ^ preliminary haskell object  data
-    -> TiData               -- ^ front end output
-    -> IO (CollectedHo,Ho)  -- ^ (new accumulated ho, final ho for this modules)
-processDecls cho ho' tiData = do
-    -- some useful values
-    let ho = choHo cho
-        -- XXX typechecker drops foreign exports!
-        decls  = tiDataDecls tiData ++ [ x | x@HsForeignExport {} <- originalDecls ]
-        originalDecls =  concat [ hsModuleDecls  m | (_,m) <- tiDataModules tiData ]
-
-    -- build datatables
-    let dataTable = toDataTable (getConstructorKinds (hoKinds $ hoTcInfo ho')) (tiAllAssumptions tiData) originalDecls (hoDataTable $ hoBuild ho)
-        classInstances = deriveClasses (choCombinators cho) dataTable
-        fullDataTable = dataTable `mappend` hoDataTable (hoBuild ho)
-    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
-
-    wdump FD.Derived $
-        mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) classInstances
-    -- initial program
-    let prog = program {
-            progDataTable = fullDataTable,
-            progExternalNames = choExternalNames cho,
-            progModule = head (fsts $ tiDataModules tiData)
-            }
-
-    -- Convert Haskell decls to E
-    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
-    let ds = [ (v,e) | (v,e) <- classInstances ] ++  [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ]
- --   sequence_ [lintCheckE onerrNone fullDataTable v e | (_,v,e) <- ds ]
-
-    -- Build rules from instances, specializations, and user specified rules and catalysts
-    instanceRules <- createInstanceRules fullDataTable (hoClassHierarchy $ hoTcInfo ho')  (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) <- massocs rules', k `notMember` defined ] `intersection` defined
-        defined = fromList $ map (tvrIdent . fst) ds :: IdSet
-
-    -- our initial program
-    prog <- return prog { progSeasoning = seasoning }
-    Identity prog <- return $ programMapDs (\ (t,e) -> return (shouldBeExported (getExports $ hoTcInfo ho') t,e)) $ atomizeApps False (programSetDs ds prog)
-
-    -- now we must attach rules to the existing chos, as well as the current ones
-    let addRule c = case mlookup (combIdent c) rules' of
-            Nothing -> c
-            Just rs -> combRules_u (map ruleUpdate . List.union rs) c
-    prog <- return $ progCombinators_u (map addRule) prog
-    cho <- return $ choCombinators_u (fmap addRule) cho
-
-    -- Here we substitute in all the original types, with rules and properties defined in the current module included
-    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
-
-
-    -- initial pass, performs
-    -- eta expansion of definitons
-    -- simplify
-    -- type analysis
-    -- floating outward
-    -- simplify
-    -- floating inward
-
-    let sopt = SS.cacheSimpOpts SS.emptySimplifyOpts {
-            SS.so_boundVars = choCombinators cho,
-            SS.so_forwardVars = progSeasoning prog
-            }
-    let tparms = transformParms {
-            transformPass = "PreInit",
-            transformDumpProgress = verbose
-            }
-
-    -- quick float inward pass to inline once used functions and prune unused ones
-    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]
-        when coreMini $ putErrLn ("----\n" ++ names)
-        let tparms = transformParms { transformPass = "Init", transformDumpProgress = coreMini }
-
-
-        mprog <- evaluate $ etaAnnotateProgram mprog
-
-        mprog <- simplifyProgram sopt "Init-One" coreMini mprog
-
-        -- | this catches more static arguments if we wait until after the initial normalizing simplification pass
-        mprog <- transformProgram tparms { transformSkipNoStats = True, transformCategory = "SimpleRecursive"
-                                         , transformOperation = return . staticArgumentTransform } mprog
-
-        mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformPass = "PreInit"
-                                         , transformOperation = typeAnalyze True } mprog
-
-        mprog <- transformProgram tparms { transformCategory = "FloatOutward", transformOperation = floatOutward } mprog
-        -- perform another supersimplify in order to substitute the once used
-        -- variables back in and replace the variable of case of variables with
-        -- the default binding of the case statement.
-
-        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 -- mapM_ (\ (v,lc) -> printCheckName'' fullDataTable v lc) (programDs mprog)
-        when miniCoreSteps $ Stats.printLStat (optStatLevel options) ("InitialOptimize:" ++ names) (progStats mprog)
-        --wdump FD.Progress $ let SubProgram rec = progType mprog in  putErr (if rec then "*" else ".")
-        wdump FD.Progress $ let SubProgram isRec = progType mprog in  progressIOSteps pr_r (if isRec then "*" else ".")
-        return mprog
-    lintCheckProgram onerrNone prog
-    --putProgressLn "Initial optimization pass"
-
-    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 $ programDecomposedDs prog) 25 '.'
-
-    -- This is the main function that optimizes the routines before writing them out
-    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)
---        liftIO $ wdump FD.Progress $ putErr (replicate wws 'w')
-        mprog <- return mprog'
-
-        mprog <- simplifyProgram sopt "Simplify-Three" 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 = "WorkWrap2", transformOperation = return . workWrapProgram } mprog
-        --mprog <- simplifyProgram sopt "Simplify-Four" coreMini mprog
-
-
-        -- annotate our bindings for further passes
-        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 rec = progType mprog in  putErr (if rec then "*" else ".")
-        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)
-
-    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,
-        choVarMap = newMap
-        } `mappend` cho,ho' { hoBuild = newHoBuild })
-
-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 }
hunk ./src/Main.hs 97
-    if int then Interactive.interact cho else compileWholeProgram prog
+    if int then Interactive.interact cho else do
+        prog <- compileWholeProgram prog
+        compileToGrin prog
hunk ./src/Main.hs 101
-
-{-# NOINLINE compileWholeProgram #-}
-compileWholeProgram prog = do
-    performGC
-
-    when collectPassStats $ 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_ (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
-
-    unless (fopts FO.GlobalOptimize) $ 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
-        compileToGrin prog
-        exitSuccess
-
-
-    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterMethod", transformDumpProgress = verbose } prog
-    prog <- simplifyProgram SS.emptySimplifyOpts "Main-One" verbose prog
-    prog <- etaExpandProg "Main-AfterOne" prog
-    prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterSimp", transformDumpProgress = verbose } prog
-    prog <- simplifyProgram SS.emptySimplifyOpts "Main-Two" verbose prog
-
-    -- run optimization again with no rules enabled
-    prog <- return $ runIdentity $ annotateProgram mempty (\_ nfo -> return $ modifyProperties (flip (foldr S.delete) [prop_HASRULE,prop_WORKER]) nfo) letann (\_ -> return) prog
-    --prog <- transformProgram "float inward" DontIterate True programFloatInward prog
-
-    prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_finalPhase = True } "SuperSimplify no rules" verbose prog
-
-    -- We should float inward right before lambda lifting so that when a case statement is lifted out, it takes any local definitions with it.
---    prog <- transformProgram transformParms {
---        transformCategory = "FloatInward",
---        transformDumpProgress = dump FD.Progress,
---        transformOperation = programFloatInward
---        } prog
-    -- perform lambda lifting
---    prog <- denewtypeProgram 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
-
-    -- final optimization pass to clean up lambda lifting droppings
---    prog <- flip programMapBodies prog $ \ e -> do
---        let cm stats e = do
---            let sopt = mempty {  SS.so_dataTable = dataTable }
---            let (stat, e') = SS.simplifyE sopt e
---            Stats.tickStat stats stat
---            return e'
---        doopt (mangle' Nothing dataTable) False finalStats "PostLambdaLift"  cm e
---    wdump FD.Progress $ Stats.print "PostLifting" finalStats
-
-    lintCheckProgram (putErrLn "LintPostLifting") prog
-
-    wdump FD.Progress $ printEStats (programE 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
---    prog <- programFloatInward prog
-
-    when collectPassStats $ do
-        Stats.print "PassStats" Stats.theStats
-        Stats.clear Stats.theStats
-
-    prog <- return $ atomizeApps True prog
-    wdump FD.CoreMangled $ dumpCore "mangled" prog
-    compileToGrin prog
-
-
--- | this gets rid of all type variables, replacing them with boxes that can hold any type.
--- The program is still type-safe, but all polymorphism has been removed in favor of
--- implicit coercion to a universal type in preparation for the grin transformation.
-
-boxifyProgram :: Program -> IO Program
-boxifyProgram prog = ans where
-    ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog)
-    f (t,e) = do
-        e <- g e
-        return (tv t,e)
-    tv t = t { tvrType = boxify (tvrType t) }
-    g e = do
-        emapEG g (return . boxify) e -- (\e -> do putStrLn ("box: " ++ pprint e) ; return $ boxify e) e
-    boxify t | Just e <- followAlias (progDataTable prog) t = boxify e
-    boxify (EPi t e) = EPi t { tvrType = boxify (tvrType t) } (boxify e)
-    boxify v@EVar {} | canBeBox v = mktBox (getType v)
-    boxify (ELit lc) = ELit lc { litArgs = map boxify (litArgs lc) }
---    boxify v@(EAp _ _) | canBeBox v = mktBox (getType v)
-    boxify (EAp (ELam t b) e) = boxify (subst t e b)
- --   boxify (EAp a b) = EAp (boxify a) b -- TODO there should be no applications at the type level by now (boxify b)
-    boxify (EAp a b) = EAp (boxify a) (boxify b)
-    boxify s@ESort {} = s
-    boxify x = error $ "boxify: " ++ show x
-
--- | get rid of unused bindings
-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
+-- | this is called on parsed, typechecked haskell code to convert it to the internal representation
hunk ./src/Main.hs 103
+progressM c  = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr
hunk ./src/Main.hs 105
-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
-            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 }
hunk ./src/Main.hs 106
-{-
-simplifyProgramPStat sopt name dodump prog = do
-    let istat = progStats prog
-    let g =  SS.programSSimplifyPStat sopt { SS.so_dataTable = progDataTable prog } . SS.programPruneOccurance
-    prog <- transformProgram ("PS:" ++ name) IterateDone dodump g prog  { progStats = mempty }
-    when ((dodump && dump FD.Progress) || dump FD.CoreSteps) $ Stats.printStat ("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 }
hunk ./src/PackedString.hs 1
-{-# OPTIONS_GHC -ffi #-}
+{-# LANGUAGE ForeignFunctionInterface #-}