diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,30 @@ +import System.Cmd (system) +import System.FilePath (()) +import Control.Monad (when, unless) import Distribution.Simple -main = defaultMain +import Distribution.Simple.LocalBuildInfo +import Distribution.PackageDescription +import Distribution.Simple.InstallDirs (CopyDest(..)) +import Distribution.Simple.LocalBuildInfo (absoluteInstallDirs, InstallDirs(..)) + +main = defaultMainWithHooks simpleUserHooks { postInst = myPostInst } + where myPostInst _ _ pkgdesc buildinfo = do + let dirs = absoluteInstallDirs pkgdesc buildinfo NoCopyDest + lhc = bindir dirs "lhc" + confargs = "--lhc --with-lhc="++lhc + lpkgdesc = localPkgDescr buildinfo + exes = executables lpkgdesc + sanity = any (\(Executable s _ _) -> s == "lhc") exes + unless sanity $ fail "No lhc executale found - this probably shouldn't happen" + let lhcexe = head $ filter (\(Executable s _ _) -> s == "lhc") exes + binfo = buildInfo lhcexe + customF = customFieldsBI binfo + when (withBase customF) $ installLhcPkg confargs "base" + withBase = any $ \(x,y) -> x == "x-build-base" && y == "True" + installLhcPkgs cf = mapM_ (installLhcPkg cf) + installLhcPkg cf n = do + putStrLn $ "\n[installing "++n++" package for lhc]\n" + let x = concat ["cd ","lib" n," && runghc Setup configure ",cf," && runghc Setup build && runghc Setup install"] + putStrLn $ x + system x + return () diff --git a/data/rts/lhc_rts_alloc.c b/data/rts/lhc_rts_alloc.c --- a/data/rts/lhc_rts_alloc.c +++ b/data/rts/lhc_rts_alloc.c @@ -44,7 +44,7 @@ #define alloc_count(x,y) #define print_alloc_size_stats() -#endif +#endif /* _LHC_PROFILE */ #if _LHC_GC == _LHC_GC_BOEHM @@ -131,13 +131,9 @@ } -#endif - -#elif _LHC_GC == _LHC_GC_JGC - -#error "jgc not supported yet." +#endif /* _LHC_DEBUG */ -#endif +#endif /* _LHC_GC == _LHC_GC_BOEHM */ diff --git a/data/rts/lhc_rts_header.h b/data/rts/lhc_rts_header.h --- a/data/rts/lhc_rts_header.h +++ b/data/rts/lhc_rts_header.h @@ -18,8 +18,7 @@ // #define our options #define _LHC_GC_NONE 0 -#define _LHC_JGC 1 -#define _LHC_GC_BOEHM 2 +#define _LHC_GC_BOEHM 1 #ifndef _LHC_GC diff --git a/dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs b/dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs --- a/dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs +++ b/dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs @@ -1,7 +1,6 @@ {-# OPTIONS -fglasgow-exts -cpp #-} module FrontEnd.HsParser (parse, parseHsStmt) where -import C.FFI import FrontEnd.HsSyn import FrontEnd.ParseMonad import FrontEnd.Lexer @@ -1272,14 +1271,16 @@ case happyOut10 happy_x_3 of { happy_var_3 -> case happyOut7 happy_x_5 of { happy_var_5 -> happyIn6 - (HsModule { hsModuleName = happy_var_2, hsModuleExports = happy_var_3, hsModuleImports = (fst happy_var_5), hsModuleDecls = (snd happy_var_5) } + (HsModule { hsModuleName = happy_var_2, hsModuleExports = happy_var_3, hsModuleImports = (fst happy_var_5), hsModuleDecls = (snd happy_var_5) + , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } ) `HappyStk` happyRest}}} happyReduce_5 = happySpecReduce_1 1# happyReduction_5 happyReduction_5 happy_x_1 = case happyOut7 happy_x_1 of { happy_var_1 -> happyIn6 - (HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (UnQual (HsIdent "main"))], hsModuleImports = (fst happy_var_1), hsModuleDecls = (snd happy_var_1) } + (HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (UnQual (HsIdent "main"))], hsModuleImports = (fst happy_var_1), hsModuleDecls = (snd happy_var_1) + , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } )} happyReduce_6 = happySpecReduce_3 2# happyReduction_6 @@ -1993,7 +1994,8 @@ case happyOut110 happy_x_3 of { happy_var_3 -> case happyOut46 happy_x_5 of { happy_var_5 -> happyIn32 - (HsPragmaSpecialize { hsDeclSrcLoc = happy_var_1, hsDeclBool = happy_var_2, hsDeclName = happy_var_3, hsDeclType = happy_var_5 } + (HsPragmaSpecialize { hsDeclSrcLoc = happy_var_1, hsDeclBool = happy_var_2, hsDeclName = happy_var_3, hsDeclType = happy_var_5 + , hsDeclUniq = error "hsDeclUniq not set" } ) `HappyStk` happyRest}}}} happyReduce_81 = happySpecReduce_1 27# happyReduction_81 @@ -2017,7 +2019,8 @@ case happyOut85 happy_x_4 of { happy_var_4 -> case happyOut85 happy_x_6 of { happy_var_6 -> happyIn33 - (HsRule { hsRuleSrcLoc = happy_var_1, hsRuleString = happy_var_2, hsRuleFreeVars = happy_var_3, hsRuleLeftExpr = happy_var_4, hsRuleRightExpr = happy_var_6 } + (HsRule { hsRuleSrcLoc = happy_var_1, hsRuleString = happy_var_2, hsRuleFreeVars = happy_var_3, hsRuleLeftExpr = happy_var_4, hsRuleRightExpr = happy_var_6 + , hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" } ) `HappyStk` happyRest}}}}} happyReduce_83 = happySpecReduce_3 29# happyReduction_83 diff --git a/lhc-regress/Main.hs b/lhc-regress/Main.hs new file mode 100644 --- /dev/null +++ b/lhc-regress/Main.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Setup +import TestCase + +import System.Environment +import System.Process +import System.FilePath +import System.IO +import System.Exit +import System.Directory +import Control.Monad +import Control.Exception +import System.Timeout +import Control.Concurrent +import Control.Exception +import Text.Printf +import qualified Data.ByteString.Char8 as B + +data TestResult = CompileError String + | ProgramError String + | KnownFailure + | TimeOut + | Success + deriving Show + +isSuccess Success = True +isSuccess KnownFailure = True +isSuccess _ = False + +main :: IO () +main = do (cfg,paths) <- parseArguments =<< getArgs + workChan <- newChan + resultChan <- newChan + tests <- forM paths findTestCases + let nTests = length (concat tests) + writeList2Chan workChan (concat tests) + when (cfgVerbose cfg >= 1) $ putStrLn $ "Testsuite consists of " ++ show nTests ++ " tests." + workers <- replicateM (max 1 (cfgThreads cfg)) $ forkIO $ forever $ + do test <- readChan workChan + result <- runTestCase cfg test + writeChan resultChan (test,result) + + results <- getChanContents resultChan + manager cfg True (take nTests results) + `finally` mapM_ killThread workers + + + +manager cfg False _ | not (cfgComplete cfg) + = do when (cfgVerbose cfg >= 1) $ putStrLn "Some tests failed" + exitFailure + +manager cfg True [] | cfgVerbose cfg >= 3 = putStrLn "No failures" +manager cfg True [] | cfgVerbose cfg >= 1 = putStrLn "" +manager cfg True [] = return () +manager cfg False [] = do when (cfgVerbose cfg >= 1) $ putStrLn "Some tests failed" >> exitFailure + exitFailure + +manager cfg noFailures ((tc,result):rest) + = do case () of () | cfgVerbose cfg >= 3 -> case result of + Success -> printf "%20s: %s\n" (testCaseName tc) "OK" + KnownFailure -> printf "%20s: %s\n" (testCaseName tc) "KnownFailure" + TimeOut -> printf "%20s: %s\n" (testCaseName tc) "TimeOut" + CompileError str -> printf "%20s: %s\n" (testCaseName tc) str + ProgramError str -> printf "%20s: %s\n" (testCaseName tc) str + | cfgVerbose cfg >= 1 -> if isSuccess result then putStr "." else putStr "*" + | otherwise -> return () + hFlush stdout + manager cfg (noFailures && isSuccess result) rest + +-- FIXME: Get a proper temporary directory. +runTestCase :: Config -> TestCase -> IO TestResult +runTestCase cfg tc + = bracket (createDirectoryIfMissing True testDir) + (\_ -> removeDirectoryRecursive testDir) $ \_ -> checkFail $ withTimeout $ + do let args = [ "-o", progName + , "--ho-dir", testDir + , testCasePath tc ] ++ + cfgLHCOptions cfg + when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (cfgLHCPath cfg:args) + (ret,out,err) <- execProcess (cfgLHCPath cfg) args B.empty + case ret of + ExitFailure c -> return $ CompileError $ unlines $ ["lhc failed with: " ++ show c, B.unpack err] + ExitSuccess + -> do when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (progName:testCaseArgs tc) + (ret,out,err) <- execProcess progName (testCaseArgs tc) (testCaseStdin tc) + case (testCaseStdout tc, testCaseStderr tc) of + (Just expectedOut,_) | expectedOut /= out -> return $ ProgramError $ unlines ["Unexpected stdout",B.unpack out] + (_,Just expectedErr) | expectedErr /= err -> return $ ProgramError $ unlines ["Unexpected stderr",B.unpack err] + _ -> return Success + where name = dropExtension (takeFileName (testCasePath tc)) + testDir = cfgTempDir cfg name + progName = testDir name + checkFail io = do ret <- io + if testCaseMustFail tc + then case ret of + Success -> return $ ProgramError "Known bug succeeded." + other -> return KnownFailure + else return ret + withTimeout io = do ret <- timeout (10^6 * cfgTestTimeout cfg) io + case ret of + Nothing -> return TimeOut + Just val -> return val + +-- This differs from System.Process by terminating the program if an exception is raised. +execProcess :: FilePath -> [String] -> B.ByteString -> IO (ExitCode, B.ByteString, B.ByteString) +execProcess cmd args input = do + (inh, outh, errh, pid) <- runInteractiveProcess cmd args Nothing Nothing + handle (\e -> do terminateProcess pid +#if BASE4 + throw (e::SomeException)) $ do +#else + throw e) $ do +#endif + outVar <- newEmptyMVar + forkIO $ B.hGetContents outh >>= putMVar outVar + errVar <- newEmptyMVar + forkIO $ B.hGetContents errh >>= putMVar errVar + + when (not (B.null input)) $ do B.hPutStr inh input >> hFlush inh + hClose inh + + out <- takeMVar outVar + err <- takeMVar errVar + ret <- waitForProcess pid + return (ret, out, err) diff --git a/lhc.cabal b/lhc.cabal --- a/lhc.cabal +++ b/lhc.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.2 name: lhc -version: 0.6.20081127 +version: 0.6.20081210 synopsis: LHC Haskell Compiler description: lhc is a haskell compiler which aims to produce the most efficient programs possible via whole @@ -12,7 +12,7 @@ author: John Meacham, David Himmelstrup maintainer: lemmih@gmail.com homepage: http://lhc.seize.it/ -build-type: Simple +build-type: Custom Extra-Source-Files: src/arch/generic.arch, src/arch/i686.arch, src/arch/x86_64.arch data-dir: data data-files: HsFFI.h names.txt operators.txt prelude.m4 primitives.txt props.txt wsize.h ViaGhc.hs @@ -23,6 +23,10 @@ default: False flag threaded default: False +flag lhc-regress + default: False +flag with-base + default: False Executable lhc main-is: Main.hs @@ -36,18 +40,23 @@ build-depends: containers, mtl, pretty, array, bytestring, pureMD5, binary >= 0.4.4, directory, haskeline, random, regex-compat, graphviz, fgl, unix, zlib, old-time, haskell98, - utf8-string, stringtable-atom, derive >= 0.1.4, + utf8-string, stringtable-atom, derive >= 0.1.4, Cabal >= 1.7, filepath, ansi-wl-pprint >= 0.5.0, ansi-terminal >= 0.5.0 - - + + ghc-options: -fwarn-unused-imports if flag(base4) build-depends: base >= 4 && < 5, syb + cpp-options: -DBASE4 else build-depends: base >= 3 && < 4 Extensions: PatternSignatures + if flag(threaded) ghc-options: -threaded - + if flag(with-base) + x-build-base: True + else + x-build-base: False Other-modules: CharIO, FindFixpoint, FlagOpts, Interactive, Options, PrimitiveOperators, DataConstructors, FlagDump, GenUtil, PackedString, RawFiles, Stats, @@ -77,3 +86,17 @@ Util.Inst Util.IntBag Util.Interact Util.NameMonad Util.Once Util.Perhaps Util.RWS Util.Relation Util.SameShape Util.Seq Util.SetLike Util.TrueSet Util.UnionFind Util.UnionSolve Util.UniqueMonad Util.VarName Util.Util LHCVersion + +Executable lhc-regress + if flag(lhc-regress) + Buildable: True + else + Buildable: False + main-is: Main.hs + hs-source-dirs: lhc-regress/ + build-depends: process + if flag(base4) + build-depends: base >= 4 && < 5 + cpp-options: -DBASE4 + else + build-depends: base >= 3 && < 4 diff --git a/src/C/Generate.hs b/src/C/Generate.hs --- a/src/C/Generate.hs +++ b/src/C/Generate.hs @@ -78,7 +78,7 @@ import Data.Maybe(isNothing) import Data.Monoid import Numeric -import Text.PrettyPrint.ANSI.Leijen(Doc,nest,(<$$>)) +import Text.PrettyPrint.ANSI.Leijen(Doc,indent,(<$$>)) import qualified Data.Foldable as Seq import qualified Data.Map as Map import qualified Data.Sequence as Seq @@ -187,15 +187,15 @@ draw (SGoto (Name s)) = text "goto" <+> text s <> char ';' draw (SBlock s) = do s <- subBlockBody s - return $ vcat [char '{', nest 4 s, char '}'] + return $ vcat [char '{', indent 4 s, char '}'] draw (SIf exp thn els) = do exp <- draw exp thn <- subBlockBody thn els <- subBlockBody els - return $ text "if" <+> parens exp <+> lbrace <$> nest 4 thn <$> rbrace <+> text "else" <+> lbrace <$> nest 4 els <$> rbrace + return $ text "if" <+> parens exp <+> lbrace <$> indent 4 thn <$> rbrace <+> text "else" <+> lbrace <$> indent 4 els <$> rbrace draw (SSwitch e ts) = text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$> char '}' where - sc (Just x,ss) = do ss <- draw (SBlock ss); x <- draw x; return $ text "case" <+> x <> char ':' <$$> nest 4 (ss <$$> text "break;") - sc (Nothing,ss) = do ss <- draw (SBlock ss); return $ text "default:" <$$> ( nest 4 ss <$$> text "break;") + sc (Just x,ss) = do ss <- draw (SBlock ss); x <- draw x; return $ text "case" <+> x <> char ':' <$$> indent 4 (ss <$$> text "break;") + sc (Nothing,ss) = do ss <- draw (SBlock ss); return $ text "default:" <$$> ( indent 4 ss <$$> text "break;") md = if any isNothing (fsts ts) then empty else text "default: lhc_case_fell_off(__LINE__);" --subBlockBody s = draw s @@ -462,7 +462,7 @@ from <- draw from to <- draw to body <- draw body - return $ text "for" <> parens (i <+> equals <+> from <> semi <+> i <+> text "<" <+> to <> semi <+> i <> text "++" ) <+> lbrace <$> nest 4 body <$> rbrace + return $ text "for" <> parens (i <+> equals <+> from <> semi <+> i <+> text "<" <+> to <> semi <+> i <> text "++" ) <+> lbrace <$> indent 4 body <$> rbrace @@ -505,7 +505,7 @@ proto' = static <+> frt <> parms <$$> name <> tupled fas' static = if Public `elem` functionOptions f then empty else text "static" parms = char ' ' <> hsep [ text s | Attribute s <- functionOptions f] - return (proto, proto' $+$ lbrace $+$ nest 8 (vcat uv' <$$> body) $+$ rbrace) + return (proto, proto' $+$ lbrace $+$ indent 8 (vcat uv' <$$> body) $+$ rbrace) -- types anonStructType :: [Type] -> Type @@ -623,7 +623,7 @@ ts' <- forM (tsort ts) $ \ (n,t) -> do t <- draw t return $ t <+> tshow n <> semi - return $ text "struct" <+> tshow n <+> lbrace <$$> nest 4 (vcat $ (if structureNeedsDiscriminator s then text "what_t what;" else empty):ts') <$$> rbrace <> semi + return $ text "struct" <+> tshow n <+> lbrace <$$> indent 4 (vcat $ (if structureNeedsDiscriminator s then text "what_t what;" else empty):ts') <$$> rbrace <> semi line = text "" diff --git a/src/CharIO.hs b/src/CharIO.hs --- a/src/CharIO.hs +++ b/src/CharIO.hs @@ -15,7 +15,7 @@ import qualified IO import qualified System.IO.UTF8 as UTF8 -#if __GLASGOW_HASKELL__ >= 610 +#if BASE4 flushOut = Ex.catch (IO.hFlush IO.stdout) (\(e::SomeException) -> return ()) #else flushOut = Ex.catch (IO.hFlush IO.stdout) (\_ -> return ()) diff --git a/src/Doc/Pretty.hs b/src/Doc/Pretty.hs --- a/src/Doc/Pretty.hs +++ b/src/Doc/Pretty.hs @@ -40,10 +40,8 @@ , displayS, displayIO, displayM ) where -import IO (Handle,hPutStr,hPutChar,stdout) import Doc.DocLike hiding(empty) import qualified Doc.DocLike as DocLike -import Data.Monoid import Text.PrettyPrint.ANSI.Leijen hiding (hsep, hcat) import System.Console.ANSI diff --git a/src/E/Annotate.hs b/src/E/Annotate.hs --- a/src/E/Annotate.hs +++ b/src/E/Annotate.hs @@ -9,7 +9,6 @@ import E.Rules import E.Subst import GenUtil -import Info.Types import Name.Id import qualified Info.Info as Info import Info.Info(Info) @@ -77,7 +76,7 @@ {- This function seems to do two distinct tasks: 1) variable substitution. - 2) annotate TVars in lambdas and lets. + 2) annotate TVrs in lambdas and lets. Why can't we do this in two separate passes? Invariants: diff --git a/src/E/Demand.hs b/src/E/Demand.hs --- a/src/E/Demand.hs +++ b/src/E/Demand.hs @@ -241,8 +241,8 @@ instance DataTableMonad IM where getDataTable = asks snd -runIM :: Monad m => IM a -> DataTable -> m a -runIM (IM im) dt = return $ runReader im (mempty,dt) +runIM :: IM a -> DataTable -> a +runIM (IM im) dt = runReader im (mempty,dt) -- returns the demand type and whether it was found in the local environment or guessed determineDemandType :: TVr -> Demand -> IM (Either DemandType E) @@ -383,11 +383,8 @@ {-# NOINLINE solveDs #-} -solveDs dataTable ds = do - nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) dataTable - --flip mapM_ nds $ \ (t,_) -> - -- putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t)) - return nds +solveDs dataTable ds = + runIM (solveDs' Nothing ds fixupDemandSignature return) dataTable shouldBind ELit {} = True @@ -419,9 +416,9 @@ g True [] ds' {-# NOINLINE analyzeProgram #-} -analyzeProgram prog = do - dsOut <- solveDs (progDataTable prog) (programDs prog) - return $ programSetDs' dsOut prog +analyzeProgram prog = + let dsOut = solveDs (progDataTable prog) (programDs prog) + in programSetDs' dsOut prog $(derive makeBinary ''Demand) $(derive makeBinary ''SubDemand) diff --git a/src/E/FromHs.hs b/src/E/FromHs.hs --- a/src/E/FromHs.hs +++ b/src/E/FromHs.hs @@ -7,7 +7,6 @@ ) where import Char -import Control.Monad.Trans import Control.Monad.Identity import Control.Monad.RWS import qualified Data.Traversable as T diff --git a/src/E/Inline.hs b/src/E/Inline.hs --- a/src/E/Inline.hs +++ b/src/E/Inline.hs @@ -121,6 +121,9 @@ ds <- g [] imap $ programDecomposedCombs prog return $ programUpdate $ prog { progCombinators = ds } +{- +The boolean value represents whether the bindings are recursive. +-} programDecomposedCombs :: Program -> [(Bool,[Comb])] programDecomposedCombs prog = map f $ scc g where --g = newGraph (progCombinators prog) combIdent ( toList . (union $ progSeasoning prog) . (freeVars :: Comb -> IdSet)) @@ -134,6 +137,19 @@ programSubProgram prog rec ds = progCombinators_s ds prog { progType = SubProgram rec, progEntry = fromList (map combIdent ds) } +{- +Map recursive program groups. + +Consider the program: +x = y +y = z +z = y + +This would call 'f [x]' and 'f [y,z]'. + +The code is made by the need for substitutions. The names of bindings can't change +but their types or other associated info might. +-} programMapProgGroups :: Monad m => IdMap (Maybe E) -- ^ initial map to apply -> (Program -> m Program) diff --git a/src/E/LambdaLift.hs b/src/E/LambdaLift.hs --- a/src/E/LambdaLift.hs +++ b/src/E/LambdaLift.hs @@ -32,6 +32,7 @@ import Util.HasSize import Util.SetLike import Util.UniqueMonad +import Options (verbose) annotateId mn x = case fromId x of Just y -> toId (toName Val (mn,'f':show y)) @@ -148,10 +149,10 @@ f _ _ EAp {} = error "this should not happen" mapM_ (f (value False) mempty) [ fst (fromLam e) | (_,e) <- programDs prog] - calcFixpoint "Liftees" fixer + findFixpoint Nothing {-"Liftees"-} fixer vs <- supplyReadValues sup let nlset = (fromList [ x | (x,False) <- vs]) - printf "%d lambdas not lifted\n" (size nlset) + when verbose $ printf "%d lambdas not lifted\n" (size nlset) return nlset implies :: Value Bool -> Value Bool -> IO () diff --git a/src/E/LetFloat.hs b/src/E/LetFloat.hs --- a/src/E/LetFloat.hs +++ b/src/E/LetFloat.hs @@ -98,8 +98,8 @@ canFloatPast _ = False {-# NOINLINE programFloatInward #-} -programFloatInward :: Program -> IO Program -programFloatInward prog = do +programFloatInward :: Program -> Program +programFloatInward prog = let binds = G.scc $ G.newGraph [ (c ,freeVars c) | c <- progCombinators prog, combIdent c `notElem` map combIdent epoints ] (combIdent . fst) (idSetToList . snd) epoints = [ c | c@Comb { combHead = x } <- progCombinators prog, (tvrIdent x `member` progEntry prog) || forceNoinline x || getProperty prop_INSTANCE x || getProperty prop_SPECIALIZATION x ] (oall,pints) = sepByDropPoint dpoints (reverse binds) @@ -111,11 +111,11 @@ --Prelude.print dpoints --Prelude.putStrLn (pprint $ map fst (dsBinds binds)) --Prelude.putStrLn (pprint $ (map fst $ dsBinds oall,map (\binds -> map fst $ dsBinds binds) pints)) - let mstats = mconcat [ Stats.singleton $ "FloatInward.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds (concat pints)] + mstats = mconcat [ Stats.singleton $ "FloatInward.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds (concat pints)] mstats' = mconcat [ Stats.singleton $ "FloatInward.all.{" ++ pprint n ++ "}" | n <- map combHead $ dsBinds oall] nstats = progStats prog `mappend` mstats `mappend` mstats' --nprog <- programMapBodies (return . floatInward) nprog - return nprog { progStats = nstats } + in nprog { progStats = nstats } --cupbinds bs = f bs where @@ -213,6 +213,7 @@ --notFloatOut e = isAtomic e || whnfOrBot e notFloatOut e = False +-- This function uses IO to generate new unique names. floatOutward :: Program -> IO Program floatOutward prog = do -- set natural levels on all types @@ -304,7 +305,7 @@ mapMSnd f xs = sequence [ (,) x `liftM` f y | (x,y) <- xs] - +-- This function uses IO to generate new unique names. letBindAll :: DataTable -- ^ the data table for expanding newtypes -> Module -- ^ current module name diff --git a/src/E/SSimplify.hs b/src/E/SSimplify.hs --- a/src/E/SSimplify.hs +++ b/src/E/SSimplify.hs @@ -1043,6 +1043,7 @@ instance MonadStats SM where mticks' n k = SM $ tell (Stats.singleStat n k) >> return () + mtickStat = error "mtickStat is not defined for SM" modifyIds fn = SM $ modify f where f s@SmState { idsUsed = used, idsBound = bound, smStdGen=gen } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound', smStdGen = gen } diff --git a/src/E/Subst.hs b/src/E/Subst.hs --- a/src/E/Subst.hs +++ b/src/E/Subst.hs @@ -38,15 +38,12 @@ -} import Control.Monad.Reader -import Data.Monoid import qualified Data.Traversable as T import List hiding(union,insert,delete) import E.E import E.FreeVars() import Name.Id -import Name.Names (tc_Arrow) -import {-# SOURCE #-} E.Show import Support.FreeVars import GenUtil import Util.SetLike as S diff --git a/src/E/TypeAnalysis.hs b/src/E/TypeAnalysis.hs --- a/src/E/TypeAnalysis.hs +++ b/src/E/TypeAnalysis.hs @@ -26,7 +26,6 @@ import Fixer.Fixer import Fixer.Supply import Fixer.VMap -import Info.Info(infoMapM,infoMap) import Info.Types import Name.Id import Name.Name @@ -60,11 +59,6 @@ let lambind _ nfo = do x <- newValue fixer ( bottom :: Typ) return $ Info.insert x (Info.delete (undefined :: Typ) nfo) - lamread _ nfo | Just v <- Info.lookup nfo = do - rv <- readValue v - return (Info.insert (rv :: Typ) $ Info.delete (undefined :: Value Typ) nfo) - lamread _ nfo = return nfo - lamdel _ nfo = return (Info.delete (undefined :: Value Typ) nfo) prog <- annotateProgram mempty lambind (\_ -> return . deleteArity) (\_ -> return) prog let ds = programDs prog env = Env { envRuleSupply = ur, envValSupply = uv, envEnv = extractValMap ds } @@ -75,10 +69,15 @@ addRule $ assert vv mapM_ (sillyEntry env) entries findFixpoint Nothing fixer + let lamread _ nfo | Just v <- Info.lookup nfo = do + rv <- readValue v + return (Info.insert (rv :: Typ) $ Info.delete (undefined :: Value Typ) nfo) + lamread _ nfo = return nfo prog <- annotateProgram mempty lamread (\_ -> return) (\_ -> return) prog unusedRules <- supplyReadValues ur >>= return . fsts . filter (not . snd) unusedValues <- supplyReadValues uv >>= return . fsts . filter (not . snd) let (prog',stats) = Stats.runStatM $ specializeProgram doSpecialize (fromList unusedRules) (fromList unusedValues) prog + let lamdel _ nfo = return (Info.delete (undefined :: Value Typ) nfo) prog <- annotateProgram mempty lamdel (\_ -> return) (\_ -> return) prog' return prog { progStats = progStats prog `mappend` stats } @@ -214,7 +213,7 @@ -- | otherwise = fail $ "getValue: no varinfo: " ++ show v getValue e | Just c <- typConstant e = return $ value c getValue e = return $ value $ fuzzyConstant e -- TODO - make more accurate -getValue e = fail $ "getValue: " ++ show e +--getValue e = fail $ "getValue: " ++ show e fuzzyConstant :: E -> Typ fuzzyConstant e | Just (n,as) <- toLit e = vmapValue n (map fuzzyConstant as) @@ -255,7 +254,10 @@ -> Program -> m Program specializeProgram doSpecialize unusedRules unusedValues prog = do - (nds,_) <- specializeCombs doSpecialize SpecEnv { senvUnusedRules = unusedRules, senvUnusedVars = unusedValues, senvDataTable = progDataTable prog, senvArgs = mempty } (progCombinators prog) + (nds,_) <- specializeCombs doSpecialize SpecEnv { senvUnusedRules = unusedRules + , senvUnusedVars = unusedValues + , senvDataTable = progDataTable prog + , senvArgs = mempty } (progCombinators prog) return $ progCombinators_s nds prog @@ -329,7 +331,7 @@ let t = tvr { tvrIdent = n, tvrType = getType e } put (ns,(t,e):es) return t -caseCast t _ty e = e +--caseCast t _ty e = e specAlt :: Stats.MonadStats m => SpecEnv -> Alt E -> m (Alt E) specAlt env@SpecEnv { senvDataTable = dataTable } (Alt lc@LitCons { litArgs = ts } e) = ans where diff --git a/src/FlagOpts.hs b/src/FlagOpts.hs --- a/src/FlagOpts.hs +++ b/src/FlagOpts.hs @@ -15,7 +15,6 @@ | FullInt -- ^ extend Int and Word to 32 bits on a 32 bit machine (rather than 30) | GlobalOptimize -- ^ perform whole program E optimization | InlinePragmas -- ^ use inline pragmas - | Jgc -- ^ use the jgc garbage collector | Lint -- ^ perform lots of extra type checks | M4 -- ^ pass haskell source through m4 preprocessor | MonomorphismRestriction -- ^ enforce monomorphism restriction @@ -53,7 +52,6 @@ show ViaGhc = "via-ghc" show Wrapper = "wrapper" show Boehm = "boehm" - show Jgc = "jgc" show Profile = "profile" show Debug = "debug" show Raw = "raw" @@ -62,8 +60,6 @@ one "no-profile" = Right $ Set.delete Profile one "boehm" = Right $ Set.insert Boehm one "no-boehm" = Right $ Set.delete Boehm -one "jgc" = Right $ Set.insert Jgc -one "no-jgc" = Right $ Set.delete Jgc one "cpr" = Right $ Set.insert Cpr one "no-cpr" = Right $ Set.delete Cpr one "m4" = Right $ Set.insert M4 @@ -117,6 +113,6 @@ f (Left x) (s,xs) = (s,x:xs) {-# NOINLINE helpMsg #-} -helpMsg = "\n-- Code options --\n cpp\n pass haskell source through c preprocessor\n ffi\n support foreign function declarations\n m4\n pass haskell source through m4 preprocessor\n unboxed-tuples\n allow unboxed tuple syntax to be recognized\n unboxed-values\n allow unboxed value syntax\n\n-- Typechecking --\n defaulting\n perform defaulting of ambiguous types\n monomorphism-restriction\n enforce monomorphism restriction\n\n-- Debugging --\n lint\n perform lots of extra type checks\n\n-- Optimization Options --\n cpr\n do CPR analysis\n float-in\n perform float inward transform\n global-optimize\n perform whole program E optimization\n inline-pragmas\n use inline pragmas\n rules\n use rules\n strictness\n perform strictness analysis\n type-analysis\n perhaps a basic points-to analysis on types right after method generation\n\n-- Code Generation --\n boehm\n use Boehm garbage collector\n debug\n enable debugging code in generated executable\n full-int\n extend Int and Word to 32 bits on a 32 bit machine (rather than 30)\n jgc\n use the jgc garbage collector\n profile\n enable profiling code in generated executable\n raw\n just evaluate main to WHNF and nothing else.\n via-ghc\n compile via ghc\n wrapper\n wrap main in exception handler\n\n-- Default settings --\n default\n inline-pragmas rules wrapper float-in strictness defaulting type-analysis monomorphism-restriction boxy eval-optimize global-optimize\n" -helpFlags = ["boehm", "controlled", "cpp", "cpr", "debug", "default", "defaulting", "ffi", "float-in", "full-int", "global-optimize", "inline-pragmas", "jgc", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "via-ghc", "wrapper"] +helpMsg = "\n-- Code options --\n cpp\n pass haskell source through c preprocessor\n ffi\n support foreign function declarations\n m4\n pass haskell source through m4 preprocessor\n unboxed-tuples\n allow unboxed tuple syntax to be recognized\n unboxed-values\n allow unboxed value syntax\n\n-- Typechecking --\n defaulting\n perform defaulting of ambiguous types\n monomorphism-restriction\n enforce monomorphism restriction\n\n-- Debugging --\n lint\n perform lots of extra type checks\n\n-- Optimization Options --\n cpr\n do CPR analysis\n float-in\n perform float inward transform\n global-optimize\n perform whole program E optimization\n inline-pragmas\n use inline pragmas\n rules\n use rules\n strictness\n perform strictness analysis\n type-analysis\n perhaps a basic points-to analysis on types right after method generation\n\n-- Code Generation --\n boehm\n use Boehm garbage collector\n debug\n enable debugging code in generated executable\n full-int\n extend Int and Word to 32 bits on a 32 bit machine (rather than 30)\n profile\n enable profiling code in generated executable\n raw\n just evaluate main to WHNF and nothing else.\n via-ghc\n compile via ghc\n wrapper\n wrap main in exception handler\n\n-- Default settings --\n default\n inline-pragmas rules wrapper float-in strictness defaulting type-analysis monomorphism-restriction boxy eval-optimize global-optimize\n" +helpFlags = ["boehm", "controlled", "cpp", "cpr", "debug", "default", "defaulting", "ffi", "float-in", "full-int", "global-optimize", "inline-pragmas", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "via-ghc", "wrapper"] diff --git a/src/FrontEnd/Desugar.hs b/src/FrontEnd/Desugar.hs --- a/src/FrontEnd/Desugar.hs +++ b/src/FrontEnd/Desugar.hs @@ -44,9 +44,7 @@ import Name.Name import Name.Names import Name.VConsts -import Options import FrontEnd.Syn.Traverse -import qualified FlagOpts as FO import FrontEnd.SrcLoc removeSynonymsFromType _ t = t diff --git a/src/FrontEnd/HsParser.y b/src/FrontEnd/HsParser.y --- a/src/FrontEnd/HsParser.y +++ b/src/FrontEnd/HsParser.y @@ -18,7 +18,6 @@ { module FrontEnd.HsParser (parse, parseHsStmt) where -import C.FFI import FrontEnd.HsSyn import FrontEnd.ParseMonad import FrontEnd.Lexer @@ -149,8 +148,10 @@ | srcloc PRAGMAOPTIONS module { $3 { hsModuleSrcLoc = $1, hsModuleOptions = hsModuleOptions $3 ++ $2 } } modulep :: { HsModule } - : 'module' modid maybeexports 'where' body { HsModule { hsModuleName = $2, hsModuleExports = $3, hsModuleImports = (fst $5), hsModuleDecls = (snd $5) } } - | body { HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (UnQual (HsIdent "main"))], hsModuleImports = (fst $1), hsModuleDecls = (snd $1) } } + : 'module' modid maybeexports 'where' body { HsModule { hsModuleName = $2, hsModuleExports = $3, hsModuleImports = (fst $5), hsModuleDecls = (snd $5) + , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } } + | body { HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (UnQual (HsIdent "main"))], hsModuleImports = (fst $1), hsModuleDecls = (snd $1) + , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } } body :: { ([HsImportDecl],[HsDecl]) } : '{' bodyaux '}' { $2 } @@ -320,13 +321,15 @@ | PRAGMARULES rulelist PRAGMAEND { HsPragmaRules $ map (\x -> x { hsRuleIsMeta = $1 }) (reverse $2) } | srcloc PRAGMASPECIALIZE var '::' type PRAGMAEND - { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $3, hsDeclType = $5 } } + { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $3, hsDeclType = $5 + , hsDeclUniq = error "hsDeclUniq not set" } } | decl { $1 } rule :: { HsRule } : srcloc STRING mfreevars exp '=' exp - { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6 } } + { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6 + , hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" } } rules :: { [HsRule] } : rules optsemi rule { $3 : $1 } diff --git a/src/FrontEnd/ParseUtils.hs b/src/FrontEnd/ParseUtils.hs --- a/src/FrontEnd/ParseUtils.hs +++ b/src/FrontEnd/ParseUtils.hs @@ -87,7 +87,6 @@ checkAssertion' _ _ = fail "Illegal class assertion" tast (a,[HsTyVar n]) = return (HsAsst a [n]) -- (a,n) tast _ = fail "Invalid Class. multiparameter classes not yet supported" - tast _ = error "tast!" --checkAssertion = checkAssertion' [] -- where checkAssertion' ts (HsTyCon c) = return (c,ts) -- checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a diff --git a/src/FrontEnd/Representation.hs b/src/FrontEnd/Representation.hs --- a/src/FrontEnd/Representation.hs +++ b/src/FrontEnd/Representation.hs @@ -86,8 +86,11 @@ tChar = TCon (Tycon tc_Char kindStar) tUnit = TCon (Tycon tc_Unit kindStar) -instance Ord (IORef a) -instance Binary (IORef a) +-- Dummy instance. We'll never actually serialize a MetaVar. +-- FIXME: Prove this statically. +instance Binary MetaVar where + get = error "get not defined for MetaVar" + put = error "put not defined for MetaVar" tList = TCon (Tycon tc_List (Kfun kindStar kindStar)) @@ -286,7 +289,7 @@ t2 <- f t2 return $ t1 `arr` t2 f (TMetaVar mv) = return $ atom $ pprint mv - f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv) +-- f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv) instance DocLike d => PPrint d MetaVarType where @@ -342,9 +345,7 @@ tTTuple' ts = foldl TAp (TCon $ Tycon (unboxedNameTuple TypeConstructor n) (foldr Kfun kindUTuple $ replicate n kindStar)) ts where n = length ts -$(derive makeBinary ''MetaVarType) $(derive makeBinary ''Type) -$(derive makeBinary ''MetaVar) $(derive makeBinary ''Tycon) $(derive makeBinary ''Pred) $(derive makeBinary ''Qual) diff --git a/src/FrontEnd/Syn/Traverse.hs b/src/FrontEnd/Syn/Traverse.hs --- a/src/FrontEnd/Syn/Traverse.hs +++ b/src/FrontEnd/Syn/Traverse.hs @@ -91,9 +91,9 @@ f (HsExpTypeSig srcLoc hsExp hsQualType) = withSrcLoc srcLoc $ do hsExp' <- fn hsExp return (HsExpTypeSig srcLoc hsExp' hsQualType) - f (HsAsPat hsName hsExp) = do - hsExp' <- fn hsExp - return (HsAsPat hsName hsExp') +-- f (HsAsPat hsName hsExp) = do +-- hsExp' <- fn hsExp +-- return (HsAsPat hsName hsExp') f (HsWildCard x) = do return (HsWildCard x) f (HsIrrPat hsExp) = do hsExp' <- fnl hsExp diff --git a/src/FrontEnd/Tc/Main.hs b/src/FrontEnd/Tc/Main.hs --- a/src/FrontEnd/Tc/Main.hs +++ b/src/FrontEnd/Tc/Main.hs @@ -426,7 +426,7 @@ tiPat (HsPNeg (HsPLit (HsFloatPrim i))) typ = tiPat (HsPLit $ HsFloatPrim (negate i)) typ tiPat (HsPNeg (HsPLit (HsDoublePrim i))) typ = tiPat (HsPLit $ HsDoublePrim (negate i)) typ tiPat (HsPNeg pat) typ = fail $ "non-literal negative patterns are not allowed" -tiPat (HsPNeg pat) typ = tiPat pat typ +--tiPat (HsPNeg pat) typ = tiPat pat typ tiPat (HsPIrrPat (Located l p)) typ = do (p,ns) <- tiPat p typ diff --git a/src/FrontEnd/Tc/Monad.hs b/src/FrontEnd/Tc/Monad.hs --- a/src/FrontEnd/Tc/Monad.hs +++ b/src/FrontEnd/Tc/Monad.hs @@ -47,7 +47,6 @@ withMetaVars ) where -import Control.Monad.Error import Control.Monad.Reader import Control.Monad.Writer import qualified Data.Traversable as T @@ -80,8 +79,6 @@ import Support.CanType import Support.FreeVars import Support.Tickle -import Util.Inst -import Util.SetLike import FrontEnd.Warning import qualified FlagDump as FD import {-# SOURCE #-} FrontEnd.Tc.Class(ClassHierarchy,simplify) @@ -283,7 +280,7 @@ inst mm ts (TMetaVar mv) | Just t <- Map.lookup (metaUniq mv) mm = t inst mm ts (TMetaVar mv) = TMetaVar mv inst mm ts (TAssoc tc as bs) = TAssoc tc (map (inst mm ts) as) (map (inst mm ts) bs) - inst mm _ t = error $ "inst: " ++ show t +-- inst mm _ t = error $ "inst: " ++ show t instance Instantiate a => Instantiate [a] where diff --git a/src/FrontEnd/Tc/Type.hs b/src/FrontEnd/Tc/Type.hs --- a/src/FrontEnd/Tc/Type.hs +++ b/src/FrontEnd/Tc/Type.hs @@ -4,7 +4,7 @@ MetaVar(..), MetaVarType(..), Pred(..), - Preds(), +-- Preds(), Qual(..), Tycon(..), Type(..), @@ -14,16 +14,16 @@ kindUTuple, unfoldKind, fn, - followTaus, +-- followTaus, fromTAp, fromTArrow, module FrontEnd.Tc.Type, prettyPrintType, - readMetaVar, +-- readMetaVar, tForAll, tList, - Constraint(..), - applyTyvarMap, +-- Constraint(..), +-- applyTyvarMap, Class(), Kindvar(..), tTTuple, @@ -31,7 +31,6 @@ tyvar ) where -import Control.Monad.Identity import Control.Monad.Writer import Data.IORef import Data.List @@ -44,10 +43,7 @@ import Name.Name import FrontEnd.SrcLoc import FrontEnd.Tc.Kind -import Name.Names -import Name.VConsts import FrontEnd.Representation -import Support.CanType import Support.FreeVars import Support.Tickle diff --git a/src/FrontEnd/TypeSynonyms.hs b/src/FrontEnd/TypeSynonyms.hs --- a/src/FrontEnd/TypeSynonyms.hs +++ b/src/FrontEnd/TypeSynonyms.hs @@ -7,7 +7,6 @@ showSynonym ) where -import Control.Monad.Identity import Control.Monad.Writer import Data.Monoid import Data.Binary diff --git a/src/Grin/DeadCode.hs b/src/Grin/DeadCode.hs --- a/src/Grin/DeadCode.hs +++ b/src/Grin/DeadCode.hs @@ -41,7 +41,7 @@ mapM_ (go fixer pappFuncs suspFuncs usedFuncs usedArgs usedCafs postInline) (grinFuncs grin) - calcFixpoint "Dead Code" fixer + findFixpoint Nothing {-"Dead Code"-} fixer ua <- supplyReadValues usedArgs uc <- supplyReadValues usedCafs uf <- supplyReadValues usedFuncs diff --git a/src/Grin/Devolve.hs b/src/Grin/Devolve.hs --- a/src/Grin/Devolve.hs +++ b/src/Grin/Devolve.hs @@ -11,9 +11,10 @@ import Grin.Grin import Grin.Noodle import Support.FreeVars +import Options (verbose) devolveTransform = transformParms { - transformDumpProgress = True, + transformDumpProgress = verbose, transformCategory = "Devolve", transformPass = "Grin", transformOperation = devolveGrin diff --git a/src/Grin/FromE.hs b/src/Grin/FromE.hs --- a/src/Grin/FromE.hs +++ b/src/Grin/FromE.hs @@ -12,7 +12,7 @@ import qualified Data.Map as Map import StringTable.Atom -import C.Arch +--import C.Arch import C.FFI hiding(Primitive) import C.Prims import Control.Monad.Identity @@ -38,7 +38,7 @@ import Stats(mtick) import Support.CanType import Support.FreeVars -import Support.Tuple +--import Support.Tuple import Util.Graph as G import Util.Once import Util.SetLike @@ -134,8 +134,8 @@ f x = (x,map (toType tyINode . tvrType ) as,toTypes TyNode (getType (e::E) :: E)) -stringNameToTy :: String -> Ty -stringNameToTy n = TyPrim (archOpTy archInfo n) +--stringNameToTy :: String -> Ty +--stringNameToTy n = TyPrim (archOpTy archInfo n) toType :: Ty -> E -> Ty toType node = toty . followAliases mempty where @@ -202,7 +202,7 @@ let tvrAtom t = liftM convertName (fromId $ tvrIdent t) let ef x = do n <- tvrAtom x return (n, [] :-> discardResult (App (scTag x) [] [])) - ep x = do putStrLn ("EP FOR "++show x) + ep x = do when verbose $ putStrLn ("EP FOR "++show x) n <- tvrAtom x case Info.lookup (tvrInfo x) of Just l -> return [(n, l)] diff --git a/src/Grin/Lint.hs b/src/Grin/Lint.hs --- a/src/Grin/Lint.hs +++ b/src/Grin/Lint.hs @@ -73,7 +73,7 @@ putErrLn $ "\n>>> Before " ++ name dumpGrin ("lint-before-" ++ name) prog putErrLn $ "\n>>>" -#if __GLASGOW_HASKELL__ >= 610 +#if BASE4 putErrLn (show (e::SomeException)) #else putErrLn (show e) diff --git a/src/Grin/NodeAnalyze.hs b/src/Grin/NodeAnalyze.hs --- a/src/Grin/NodeAnalyze.hs +++ b/src/Grin/NodeAnalyze.hs @@ -8,7 +8,6 @@ import Control.Monad(forM, forM_, when) import Control.Monad.RWS(MonadWriter(..), RWS(..)) -import Control.Monad.Identity(runIdentity) import Data.Monoid import Data.Maybe import qualified Data.Map as Map @@ -118,7 +117,7 @@ --putStrLn "----------------------------" --print cs --putStrLn "----------------------------" - putStrLn "-- NodeAnayze" + -- putStrLn "-- NodeAnalyze" (rm,res) <- solve (const (return ())) cs --(rm,res) <- solve putStrLn cs let cmap = Map.map (fromJust . flip Map.lookup res) rm diff --git a/src/Grin/Optimize.hs b/src/Grin/Optimize.hs --- a/src/Grin/Optimize.hs +++ b/src/Grin/Optimize.hs @@ -14,7 +14,7 @@ import Support.FreeVars import Util.Graph import Util.SetLike - +import Options (verbose) data PExp = PExp { pexpUniq :: Int, @@ -169,10 +169,10 @@ grinSpeculate :: Grin -> IO Grin grinSpeculate grin = do let ss = findSpeculatable grin - putStrLn "Speculatable:" - mapM_ Prelude.print ss + when verbose $ putStrLn "Speculatable:" + when verbose $ mapM_ Prelude.print ss let (grin',stats) = runStatM (performSpeculate ss grin) - Stats.printStat "Speculate" stats + when verbose $ Stats.printStat "Speculate" stats return grin' diff --git a/src/Grin/SSimplify.hs b/src/Grin/SSimplify.hs --- a/src/Grin/SSimplify.hs +++ b/src/Grin/SSimplify.hs @@ -4,6 +4,7 @@ import qualified Data.IntMap as IM import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Monoid import Data.DeriveTH import Data.Derive.All @@ -55,11 +56,11 @@ tellFV v = tell mempty { colFreeVars = freeVars v } -simplify :: Grin -> IO Grin -simplify grin = do +simplify :: Grin -> Grin +simplify grin = let (fs,_,SCol { colStats = stats}) = runRWS fun mempty SState { usedVars = mempty } S fun = simpFuncs (grinFunctions grin) - return grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats } + in grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats } simpFuncs :: [FuncDef] -> S [FuncDef] diff --git a/src/Grin/Show.hs b/src/Grin/Show.hs --- a/src/Grin/Show.hs +++ b/src/Grin/Show.hs @@ -18,7 +18,7 @@ import StringTable.Atom import C.Prims -import Data.Graph.Inductive.Graph(mkGraph,nmap) +import Data.Graph.Inductive.Graph(mkGraph) import Data.Graph.Inductive.Tree import Doc.Attr import Doc.DocLike @@ -27,8 +27,6 @@ import Grin.Grin import Grin.Noodle import Grin.Val -import Name.VConsts -import Cmm.Number import Options import Support.CanType import Support.FreeVars diff --git a/src/Grin/Simplify.hs b/src/Grin/Simplify.hs --- a/src/Grin/Simplify.hs +++ b/src/Grin/Simplify.hs @@ -1,7 +1,5 @@ module Grin.Simplify(simplify,renameUniqueGrin) where -import Char -import Control.Monad.Identity import Control.Monad.Writer import Control.Monad.State import Control.Monad.Trans @@ -13,7 +11,6 @@ import qualified Data.Set as Set import StringTable.Atom -import C.Prims import GenUtil hiding(putErrLn,replicateM_) import Grin.Grin import Grin.Noodle @@ -28,6 +25,7 @@ import Util.SetLike import qualified Util.Seq as Seq import qualified Util.Histogram as Hist +import Options (verbose) -- perform a number of simple simplifications. -- inline very small and builtin-wrapper functions @@ -185,10 +183,11 @@ | tagIsSuspFunction t = App (tagFlipFunction t) xs typ doEval n typ = error $ show ("doEval", n,typ) - +{- fromBap :: Monad m => Atom -> m Int fromBap t | 'B':'a':'p':'_':(n:ns) <- fromAtom t, isDigit n = return $ read (n:takeWhile isDigit ns) fromBap t = fail "not Bap" +-} -- This only binds variables to variables varBind :: Monad m => Val -> Val -> m (Map.Map Var Val) diff --git a/src/Ho/Build.hs b/src/Ho/Build.hs --- a/src/Ho/Build.hs +++ b/src/Ho/Build.hs @@ -38,7 +38,6 @@ import Doc.Pretty import E.E import E.Rules -import E.Show import E.Traverse(emapE) import E.TypeCheck() import FrontEnd.Class @@ -68,7 +67,7 @@ import qualified Util.Graph as G import qualified Data.Digest.Pure.MD5 as MD5 import qualified Codec.Binary.UTF8.String as UTF8 - +import System.FilePath (takeExtension) -- -- Ho File Format @@ -142,10 +141,10 @@ $(derive makeMonoid ''Done) $(derive makeUpdate ''Done) -fileOrModule f = case reverse f of - ('s':'h':'.':_) -> Right f - ('s':'h':'l':'.':_) -> Right f - _ -> Left $ Module f +fileOrModule f = case takeExtension f of + ".hs" -> Right f + ".lhs" -> Right f + _ -> Left $ Module f {-# NOINLINE doDependency #-} doDependency :: [String] -> IO () diff --git a/src/Info/Binary.hs b/src/Info/Binary.hs --- a/src/Info/Binary.hs +++ b/src/Info/Binary.hs @@ -2,7 +2,6 @@ import Data.Dynamic import qualified Data.Map as Map -import Data.Word import StringTable.Atom(HasHash(..)) import Data.Binary diff --git a/src/Info/Info.hs b/src/Info/Info.hs --- a/src/Info/Info.hs +++ b/src/Info/Info.hs @@ -60,9 +60,11 @@ instance Show Info where show (Info ds) = show (sortUnder (show . entryType) ds) +-- FIXME: Why don't we derive Data? instance Data Info where toConstr = undefined dataTypeOf = undefined + gunfold = undefined instance Monoid Info where mempty = empty diff --git a/src/Interactive.hs b/src/Interactive.hs --- a/src/Interactive.hs +++ b/src/Interactive.hs @@ -135,7 +135,7 @@ xs -> f "" xs where f opt [x] = (opt,x) f opt ~(x:xs) = f (x ++ opt) xs -#if __GLASGOW_HASKELL__ >= 610 +#if BASE4 rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\(e::SomeException) -> return Nothing) #else rx <- CE.catch ( Just `fmap` evaluate (mkRegex reg)) (\_ -> return Nothing) @@ -154,7 +154,7 @@ do_expr act s = case parseStmt (s ++ "\n") of Left m -> putStrLn m >> return act Right e -> do -#if __GLASGOW_HASKELL__ >= 610 +#if BASE4 CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show (e::SomeException)) #else CE.catch (runIn isStart { stateInteract = act } $ executeStatement e) $ (\e -> putStrLn $ show e) diff --git a/src/LHCVersion.hs b/src/LHCVersion.hs --- a/src/LHCVersion.hs +++ b/src/LHCVersion.hs @@ -6,7 +6,7 @@ import qualified Paths_lhc as P package = "lhc" -tag = "kami" +tag = "zhu" version = showVersion P.version shortVersion = concat $ intersperse "." $ map show $ init $ versionBranch P.version revision = show $ tail $ versionBranch P.version diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -9,7 +9,7 @@ import Prelude hiding(putStrLn, putStr,print) import qualified Data.Map as Map import qualified Data.Set as Set -import List(group,union) +import qualified List import qualified System import qualified System.Exit as Exit import Util.Util @@ -78,8 +78,9 @@ import qualified Interactive import qualified Stats import qualified System.IO as IO +import System.FilePath (takeExtension) -#if __GLASGOW_HASKELL__ >= 610 +#if BASE4 runMain action = Control.Exception.catches (action >> return ()) [ Handler $ \ (e::Exit.ExitCode) -> throw e , Handler $ \ (e::SomeException) -> putErrDie $ show e ] @@ -94,7 +95,7 @@ progressM c = wdump FD.Progress $ (c >>= putErrLn) >> hFlush stderr -collectPassStats = True +collectPassStats = verbose bracketHtml action = do (argstring,_) <- getArgString @@ -136,10 +137,10 @@ processFilesModules fs = do compileModEnv =<< parseFiles fs processInitialHo processDecls -fileOrModule f = case reverse f of - ('s':'h':'.':_) -> Right f - ('s':'h':'l':'.':_) -> Right f - _ -> Left $ Module f +fileOrModule f = case takeExtension f of + ".hs" -> Right f + ".lhs" -> Right f + _ -> Left $ Module f --barendregtProg prog = transformProgram transBarendregt prog @@ -240,6 +241,7 @@ -- Convert Haskell decls to E let allAssumps = (tiAllAssumptions tiData `mappend` hoAssumps (hoBuild ho)) theProps = fromList [ (toId x,y) | (x,y) <- Map.toList $ tiProps tiData] + -- 'convertDecls' uses its monad for error handling. ds' <- convertDecls tiData theProps (hoClassHierarchy $ hoBuild 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 ] @@ -318,7 +320,7 @@ -- quick float inward pass to inline once used functions and prune unused ones prog <- transformProgram tparms { transformCategory = "FloatInward", - transformOperation = programFloatInward + transformOperation = return . programFloatInward } prog let fint mprog = do @@ -333,9 +335,11 @@ mprog <- barendregtProg 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 { transformSkipNoStats = True, transformCategory = "SimpleRecursive" + , transformOperation = return . staticArgumentTransform } mprog - mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformPass = "PreInit", transformOperation = typeAnalyze True } 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 @@ -346,8 +350,8 @@ mprog <- barendregtProg mprog mprog <- transformProgram tparms { transformCategory = "typeAnalyze", transformOperation = typeAnalyze True } mprog - mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog - mprog <- Demand.analyzeProgram mprog + mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = return . programFloatInward } mprog + mprog <- return $ Demand.analyzeProgram mprog lintCheckProgram onerrNone mprog mprog <- simplifyProgram sopt "Init-Three-AfterDemand" False mprog mprog <- barendregtProg mprog @@ -371,10 +375,10 @@ prog <- transformProgram tparms { transformPass = "Init-Big-One", transformCategory = "FloatInward", - transformOperation = programFloatInward + transformOperation = return . programFloatInward } prog - prog <- Demand.analyzeProgram prog + prog <- return $ Demand.analyzeProgram prog prog <- simplifyProgram' sopt "Init-Big-One" verbose (IterateMax 4) prog wdump FD.Progress $ @@ -393,11 +397,11 @@ mprog <- simplifyProgram sopt "Simplify-One" coreMini mprog mprog <- barendregtProg mprog - mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog - mprog <- Demand.analyzeProgram mprog + mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = return . programFloatInward } mprog + mprog <- return $ Demand.analyzeProgram mprog mprog <- simplifyProgram sopt "Simplify-Two" coreMini mprog - mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = programFloatInward } mprog - mprog <- Demand.analyzeProgram mprog + mprog <- transformProgram tparms { transformCategory = "FloatInward", transformOperation = return . programFloatInward } mprog + mprog <- return $ 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) @@ -415,7 +419,7 @@ -- annotate our bindings for further passes mprog <- return $ etaAnnotateProgram mprog - mprog <- Demand.analyzeProgram mprog + mprog <- return $ Demand.analyzeProgram mprog mprog <- return $ E.CPR.cprAnalyzeProgram mprog put $ fromList [ (combIdent c,c) | c <- progCombinators mprog] `S.union` smap @@ -457,13 +461,16 @@ ds' = reachable (newGraph (progCombinators prog) combIdent freeVars) (toList $ progEntry prog) programPrune :: Program -> IO Program -programPrune prog = transformProgram transformParms { transformCategory = "PruneUnreachable", transformDumpProgress = miniCorePass, transformOperation = evaluate . programPruneUnreachable } prog +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 + transformProgram transformParms { transformPass = pass, transformCategory = "EtaExpansion" + , transformDumpProgress = miniCorePass, transformOperation = evaluate . f } prog getExports ho = Set.fromList $ map toId $ concat $ Map.elems (hoExports ho) @@ -537,11 +544,11 @@ --wdump FD.Core $ printProgram prog prog <- if (fopts FO.TypeAnalysis) then do typeAnalyze False prog else return prog - 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' ] + 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 --wdump FD.Core $ printProgram prog @@ -569,7 +576,7 @@ exitSuccess - prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterMethod", transformDumpProgress = True } prog + prog <- transformProgram transTypeAnalyze { transformPass = "Main-AfterMethod", transformDumpProgress = verbose } prog prog <- barendregtProg prog @@ -609,7 +616,7 @@ prog <- transformProgram transformParms { transformCategory = "BoxifyProgram", transformDumpProgress = dump FD.Progress, transformOperation = boxifyProgram } prog prog <- programPrune prog - prog <- Demand.analyzeProgram prog + prog <- return $ 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 @@ -656,7 +663,7 @@ -- -- also, all rules are deleted. -boxifyProgram :: Program -> IO Program +boxifyProgram :: Monad m => Program -> m Program boxifyProgram prog = ans where ans = do programMapDs f (progCombinators_u (map $ combRules_s []) prog) f (t,e) = do @@ -690,7 +697,7 @@ transformDumpProgress = verbose, transformCategory = "Simplify", transformPass = "Grin", - transformOperation = Grin.SSimplify.simplify, + transformOperation = evaluate . Grin.SSimplify.simplify, transformIterate = IterateDone } @@ -700,7 +707,7 @@ prog <- return $ atomizeApps True prog wdump FD.CoreMangled $ printProgram prog x <- Grin.FromE.compile prog - Stats.print "Grin" Stats.theStats + when verbose $ Stats.print "Grin" Stats.theStats wdump FD.GrinInitial $ do dumpGrin "initial" x --x <- return $ normalizeGrin x x <- transformGrin simplifyParms x @@ -729,7 +736,7 @@ False -> opt s grin x <- deadCode stats (grinEntryPointNames x) x -- XXX - x <- Grin.SSimplify.simplify x + x <- evaluate $ Grin.SSimplify.simplify x --x <- transformGrin simplifyParms x x <- pushGrin x @@ -743,7 +750,7 @@ x <- opt "Optimization" x --lintCheckGrin x - x <- Grin.SSimplify.simplify x + x <- evaluate $ Grin.SSimplify.simplify x wdump FD.OptimizationStats $ Stats.print "Optimization" stats @@ -752,7 +759,7 @@ lintCheckGrin x x <- createEvalApply x lintCheckGrin x - x <- Grin.SSimplify.simplify x + x <- evaluate $ Grin.SSimplify.simplify x lintCheckGrin x x <- transformGrin devolveTransform x @@ -781,11 +788,13 @@ progress ("Writing " ++ show cf) (argstring,sversion) <- getArgString let - boehmOpts | fopts FO.Boehm = ["-D_LHC_GC=2", "-lgc"] + boehmOpts | fopts FO.Boehm = ["-D_LHC_GC=1", "-lgc"] | otherwise = [] profileOpts | fopts FO.Profile = ["-D_LHC_PROFILE=1"] | otherwise = [] - comm = shellQuote $ [optCC options, "-std=gnu99", "-D_GNU_SOURCE", "-falign-functions=4", "-ffast-math", "-Wshadow", "-Wextra", "-Wall", "-Wno-unused-parameter", "-o", fn, cf ] ++ (map ("-l" ++) rls) ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts + comm = shellQuote $ [optCC options, "-std=gnu99", "-D_GNU_SOURCE", "-falign-functions=4", "-ffast-math" + , "-Wshadow", "-Wextra", "-Wall", "-Wno-unused-parameter", "-o", fn, cf ] ++ + (map ("-l" ++) rls) ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts debug = if fopts FO.Debug then ["-g"] else ["-DNDEBUG", "-O3", "-fomit-frame-pointer"] globalvar n c = "char " ++ n ++ "[] = \"" ++ c ++ "\";" writeFile cf $ unlines [globalvar "lhc_c_compile" comm, globalvar "lhc_command" argstring,globalvar "lhc_version" sversion,"",cg] @@ -816,7 +825,11 @@ 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 } + 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 } @@ -831,7 +844,11 @@ 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 } + 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 } @@ -861,7 +878,7 @@ putErrLn $ "\n>>> Before " ++ name printProgram prog putErrLn $ "\n>>>" -#if __GLASGOW_HASKELL__ >= 610 +#if BASE4 putErrLn (show (e::SomeException)) #else putErrLn (show e) diff --git a/src/Name/VConsts.hs b/src/Name/VConsts.hs --- a/src/Name/VConsts.hs +++ b/src/Name/VConsts.hs @@ -3,7 +3,6 @@ import Data.Traversable import Data.Foldable import Control.Applicative -import Data.Monoid import Data.DeriveTH import Data.Derive.All @@ -29,7 +28,7 @@ tRational = error "tRational" tChar = error "tChar" tIntzh = error "tIntzh" --- tEnumzh = error "tEnumzh" + tEnumzh = error "tEnumzh" tIntegerzh = error "tIntegerzh" tCharzh = error "tCharzh" tStar = error "VConsts: tStar" diff --git a/src/PackedString.hs b/src/PackedString.hs --- a/src/PackedString.hs +++ b/src/PackedString.hs @@ -49,20 +49,16 @@ ) where -import Data.Array.IO import Data.Typeable import Data.Char import Data.Int import Data.Binary import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSUTF8 -import qualified Codec.Binary.UTF8.String as UTF8 import Bits import GHC.Exts -import Data.Array.Base import Word import Data.Monoid -import Foreign.C.Types instance Monoid PackedString where mempty = nilPS diff --git a/src/RawFiles.hs b/src/RawFiles.hs --- a/src/RawFiles.hs +++ b/src/RawFiles.hs @@ -1,7 +1,5 @@ module RawFiles where import System.IO.Unsafe -import System.Directory -import System.FilePath import Paths_lhc {-# NOINLINE hsffi_h #-} diff --git a/src/Support/CFF.hs b/src/Support/CFF.hs --- a/src/Support/CFF.hs +++ b/src/Support/CFF.hs @@ -22,18 +22,14 @@ writeCFF )where -import Control.Concurrent.MVar import Control.Monad import Data.Bits import Data.Char import Data.List import Data.Word -import System import System.IO -import System.IO.Unsafe import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map type FileOffset = Word diff --git a/src/Util/BitSet.hs b/src/Util/BitSet.hs --- a/src/Util/BitSet.hs +++ b/src/Util/BitSet.hs @@ -54,7 +54,7 @@ toList (BitSet v) = f 0 where f c | c >= 32 = [] | otherwise = if testBit v c then c:f (c + 1) else f (c + 1) - + sfilter = error "sfilter not defined for BitSet" instance Show BitSet where @@ -73,6 +73,7 @@ toList (EnumBitSet s) = map toEnum $ toList s member x (EnumBitSet s) = member (fromEnum x) s delete x (EnumBitSet s) = EnumBitSet $ delete (fromEnum x) s + sfilter = error "sfilter not defined for EnumBitSet" instance (Enum a,Show a) => Show (EnumBitSet a) where showsPrec n bs = showsPrec n (toList bs) diff --git a/src/Util/ContextMonad.hs b/src/Util/ContextMonad.hs --- a/src/Util/ContextMonad.hs +++ b/src/Util/ContextMonad.hs @@ -1,7 +1,6 @@ module Util.ContextMonad where import Control.Monad.Error -import Control.Monad.Identity import Control.Monad diff --git a/src/Util/Inst.hs b/src/Util/Inst.hs --- a/src/Util/Inst.hs +++ b/src/Util/Inst.hs @@ -7,7 +7,6 @@ import qualified Data.IntMap as IM import Data.Monoid import List -import Data.Foldable hiding(or) import Data.Traversable diff --git a/src/Util/IntBag.hs b/src/Util/IntBag.hs --- a/src/Util/IntBag.hs +++ b/src/Util/IntBag.hs @@ -124,29 +124,22 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null) import Data.Bits -import Data.Int -import qualified Data.IntSet as IntSet +--import Data.Int +--import qualified Data.IntSet as IntSet import Data.Monoid (Monoid(..)) -import Data.Typeable -import Data.Foldable (Foldable(foldMap)) +--import Data.Typeable +--import Data.Foldable (Foldable(foldMap)) #if __GLASGOW_HASKELL__ -import Text.Read -import Data.Generics.Basics -import Data.Generics.Instances +--import Text.Read +--import Data.Generics.Basics +--import Data.Generics.Instances #endif -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Word import GHC.Exts ( Word(..), Int(..), shiftRL# ) -#elif __GLASGOW_HASKELL__ -import Word -import GlaExts ( Word(..), Int(..), shiftRL# ) -#else -import Data.Word -#endif + --infixl 9 \\{-This comment teaches CPP correct behaviour -} -- A "Nat" is a natural machine word (an unsigned Int) @@ -933,14 +926,14 @@ toList :: IntBag -> [(Key,Int)] toList t = foldWithKey (\k x xs -> (k,x):xs) [] t - +{- -- | /O(n)/. Convert the map to a list of key\/value pairs where the -- keys are in ascending order. toAscList :: IntBag -> [(Key,Int)] toAscList t = -- NOTE: the following algorithm only works for big-endian trees let (pos,neg) = span (\(k,x) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos - +-} -- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs. fromList :: [(Key,Int)] -> IntBag fromList xs @@ -1154,12 +1147,12 @@ zero i m = (natFromInt i) .&. (natFromInt m) == 0 -nomatch,match :: Key -> Prefix -> Mask -> Bool +nomatch :: Key -> Prefix -> Mask -> Bool nomatch i p m = (mask i m) /= p -match i p m - = (mask i m) == p +--match i p m +-- = (mask i m) == p mask :: Key -> Mask -> Prefix mask i m diff --git a/src/Util/Interact.hs b/src/Util/Interact.hs --- a/src/Util/Interact.hs +++ b/src/Util/Interact.hs @@ -98,7 +98,7 @@ let commands' = commands ++ [ (n,h) | InteractCommand { commandName = n, commandHelp = h } <- interactCommands act ] help_text = unlines $ buildTableLL (commands' ++ extra_help) let args s = [ bb | bb@(n,_) <- commands', s `isPrefixOf` n ] - expand s = fsts (args s) ++ filter (isPrefixOf s) (interactSettables act) +-- expand s = fsts (args s) ++ filter (isPrefixOf s) (interactSettables act) let showSet | null $ interactSettables act = putStrLn "Nothing may be set" diff --git a/src/Util/RWS.hs b/src/Util/RWS.hs --- a/src/Util/RWS.hs +++ b/src/Util/RWS.hs @@ -21,11 +21,8 @@ import Prelude -import Control.Monad -import Control.Monad.Fix -import Control.Monad.Trans -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.Reader ( MonadReader(..), asks ) +import Control.Monad.Writer ( MonadWriter(..), censor, WriterT(..) ) import Control.Monad.State import Data.Monoid diff --git a/src/Util/ReaderWriter.hs b/src/Util/ReaderWriter.hs --- a/src/Util/ReaderWriter.hs +++ b/src/Util/ReaderWriter.hs @@ -2,7 +2,6 @@ module Util.ReaderWriter(ReaderWriter(),runReaderWriter) where -import Data.Monoid import Control.Monad.Reader import Control.Monad.Writer -- strict unboxed ReaderWriter monad diff --git a/src/Util/Seq.hs b/src/Util/Seq.hs --- a/src/Util/Seq.hs +++ b/src/Util/Seq.hs @@ -93,8 +93,8 @@ = Seq (\ts -> xs++ts) -tell x = W.tell (Util.Seq.singleton x) -tells xs = W.tell (Util.Seq.fromList xs) +--tell x = W.tell (Util.Seq.singleton x) +--tells xs = W.tell (Util.Seq.fromList xs) --instance Monoid (Seq.Seq a) where -- mempty = Seq.empty diff --git a/src/Util/UnionSolve.hs b/src/Util/UnionSolve.hs --- a/src/Util/UnionSolve.hs +++ b/src/Util/UnionSolve.hs @@ -7,7 +7,6 @@ islte,isgte,equals ) where -import Control.Monad(when) import Data.List(intersperse) import Data.Monoid import qualified Data.Set as Set diff --git a/src/Util/UniqueMonad.hs b/src/Util/UniqueMonad.hs --- a/src/Util/UniqueMonad.hs +++ b/src/Util/UniqueMonad.hs @@ -8,7 +8,7 @@ import Control.Monad.Writer import Control.Monad.Identity - +-- FIXME: We should never rely on IO to generate unique ids. instance UniqueProducer IO where newUniq = do u <- newUnique