lhc 0.6.20081127 → 0.6.20081210
raw patch · 57 files changed
+388/−220 lines, 57 filesdep +Cabaldep +processdep ~basebuild-type:Customsetup-changednew-component:exe:lhc-regress
Dependencies added: Cabal, process
Dependency ranges changed: base
Files
- Setup.hs +29/−1
- data/rts/lhc_rts_alloc.c +3/−7
- data/rts/lhc_rts_header.h +1/−2
- dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs +8/−5
- lhc-regress/Main.hs +128/−0
- lhc.cabal +29/−6
- src/C/Generate.hs +8/−8
- src/CharIO.hs +1/−1
- src/Doc/Pretty.hs +0/−2
- src/E/Annotate.hs +1/−2
- src/E/Demand.hs +7/−10
- src/E/FromHs.hs +0/−1
- src/E/Inline.hs +16/−0
- src/E/LambdaLift.hs +3/−2
- src/E/LetFloat.hs +6/−5
- src/E/SSimplify.hs +1/−0
- src/E/Subst.hs +0/−3
- src/E/TypeAnalysis.hs +11/−9
- src/FlagOpts.hs +2/−6
- src/FrontEnd/Desugar.hs +0/−2
- src/FrontEnd/HsParser.y +8/−5
- src/FrontEnd/ParseUtils.hs +0/−1
- src/FrontEnd/Representation.hs +6/−5
- src/FrontEnd/Syn/Traverse.hs +3/−3
- src/FrontEnd/Tc/Main.hs +1/−1
- src/FrontEnd/Tc/Monad.hs +1/−4
- src/FrontEnd/Tc/Type.hs +5/−9
- src/FrontEnd/TypeSynonyms.hs +0/−1
- src/Grin/DeadCode.hs +1/−1
- src/Grin/Devolve.hs +2/−1
- src/Grin/FromE.hs +5/−5
- src/Grin/Lint.hs +1/−1
- src/Grin/NodeAnalyze.hs +1/−2
- src/Grin/Optimize.hs +4/−4
- src/Grin/SSimplify.hs +4/−3
- src/Grin/Show.hs +1/−3
- src/Grin/Simplify.hs +3/−4
- src/Ho/Build.hs +5/−6
- src/Info/Binary.hs +0/−1
- src/Info/Info.hs +2/−0
- src/Interactive.hs +2/−2
- src/LHCVersion.hs +1/−1
- src/Main.hs +56/−39
- src/Name/VConsts.hs +1/−2
- src/PackedString.hs +0/−4
- src/RawFiles.hs +0/−2
- src/Support/CFF.hs +0/−4
- src/Util/BitSet.hs +2/−1
- src/Util/ContextMonad.hs +0/−1
- src/Util/Inst.hs +0/−1
- src/Util/IntBag.hs +13/−20
- src/Util/Interact.hs +1/−1
- src/Util/RWS.hs +2/−5
- src/Util/ReaderWriter.hs +0/−1
- src/Util/Seq.hs +2/−2
- src/Util/UnionSolve.hs +0/−1
- src/Util/UniqueMonad.hs +1/−1
Setup.hs view
@@ -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 ()
data/rts/lhc_rts_alloc.c view
@@ -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 */
data/rts/lhc_rts_header.h view
@@ -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
dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs view
@@ -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
+ lhc-regress/Main.hs view
@@ -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)
lhc.cabal view
@@ -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
src/C/Generate.hs view
@@ -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 ""
src/CharIO.hs view
@@ -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 ())
src/Doc/Pretty.hs view
@@ -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
src/E/Annotate.hs view
@@ -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:
src/E/Demand.hs view
@@ -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)
src/E/FromHs.hs view
@@ -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
src/E/Inline.hs view
@@ -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)
src/E/LambdaLift.hs view
@@ -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 ()
src/E/LetFloat.hs view
@@ -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
src/E/SSimplify.hs view
@@ -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 }
src/E/Subst.hs view
@@ -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
src/E/TypeAnalysis.hs view
@@ -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
src/FlagOpts.hs view
@@ -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"]
src/FrontEnd/Desugar.hs view
@@ -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
src/FrontEnd/HsParser.y view
@@ -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 }
src/FrontEnd/ParseUtils.hs view
@@ -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
src/FrontEnd/Representation.hs view
@@ -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)
src/FrontEnd/Syn/Traverse.hs view
@@ -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
src/FrontEnd/Tc/Main.hs view
@@ -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
src/FrontEnd/Tc/Monad.hs view
@@ -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
src/FrontEnd/Tc/Type.hs view
@@ -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
src/FrontEnd/TypeSynonyms.hs view
@@ -7,7 +7,6 @@ showSynonym ) where -import Control.Monad.Identity import Control.Monad.Writer import Data.Monoid import Data.Binary
src/Grin/DeadCode.hs view
@@ -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
src/Grin/Devolve.hs view
@@ -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
src/Grin/FromE.hs view
@@ -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)]
src/Grin/Lint.hs view
@@ -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)
src/Grin/NodeAnalyze.hs view
@@ -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
src/Grin/Optimize.hs view
@@ -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'
src/Grin/SSimplify.hs view
@@ -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]
src/Grin/Show.hs view
@@ -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
src/Grin/Simplify.hs view
@@ -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)
src/Ho/Build.hs view
@@ -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 ()
src/Info/Binary.hs view
@@ -2,7 +2,6 @@ import Data.Dynamic import qualified Data.Map as Map-import Data.Word import StringTable.Atom(HasHash(..)) import Data.Binary
src/Info/Info.hs view
@@ -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
src/Interactive.hs view
@@ -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)
src/LHCVersion.hs view
@@ -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
src/Main.hs view
@@ -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)
src/Name/VConsts.hs view
@@ -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"
src/PackedString.hs view
@@ -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
src/RawFiles.hs view
@@ -1,7 +1,5 @@ module RawFiles where import System.IO.Unsafe-import System.Directory-import System.FilePath import Paths_lhc {-# NOINLINE hsffi_h #-}
src/Support/CFF.hs view
@@ -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
src/Util/BitSet.hs view
@@ -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)
src/Util/ContextMonad.hs view
@@ -1,7 +1,6 @@ module Util.ContextMonad where import Control.Monad.Error-import Control.Monad.Identity import Control.Monad
src/Util/Inst.hs view
@@ -7,7 +7,6 @@ import qualified Data.IntMap as IM import Data.Monoid import List-import Data.Foldable hiding(or) import Data.Traversable
src/Util/IntBag.hs view
@@ -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
src/Util/Interact.hs view
@@ -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"
src/Util/RWS.hs view
@@ -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
src/Util/ReaderWriter.hs view
@@ -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
src/Util/Seq.hs view
@@ -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
src/Util/UnionSolve.hs view
@@ -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
src/Util/UniqueMonad.hs view
@@ -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