lhc 0.6.20081216 → 0.6.20090126
raw patch · 102 files changed
+2175/−876 lines, 102 files
Files
- data/names.txt +3/−0
- data/rts/lhc_rts2.c +0/−1
- data/rts/lhc_rts_alloc.c +0/−2
- dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs +2/−1
- lhc-regress/Main.hs +63/−19
- lhc.cabal +7/−5
- lib/base/base.cabal +39/−32
- lib/base/src/Control/Applicative.hs +220/−0
- lib/base/src/Control/Arrow.hs +278/−0
- lib/base/src/Control/Category.hs +53/−0
- lib/base/src/Control/Monad/Fix.hs +80/−0
- lib/base/src/Control/Monad/Instances.hs +31/−0
- lib/base/src/Data/Bits.hs +23/−3
- lib/base/src/Data/Function.hs +83/−0
- lib/base/src/Data/Int.hs +1/−7
- lib/base/src/Data/Word.hs +1/−8
- lib/base/src/Foreign/C/Types.hs +49/−8
- lib/base/src/Lhc/Addr.hs +1/−0
- lib/base/src/Lhc/Basics.hs +3/−1
- lib/base/src/Lhc/Enum.hs +45/−8
- lib/base/src/Lhc/IO.hs +0/−1
- lib/base/src/Lhc/Inst/Enum.hs +69/−11
- lib/base/src/Lhc/Inst/Num.m4 +37/−0
- lib/base/src/Lhc/Inst/Read.hs +1/−1
- lib/base/src/Lhc/Inst/Show.hs +10/−5
- lib/base/src/Lhc/Inst/Storable.hs +3/−0
- lib/base/src/Lhc/List.hs +1/−1
- lib/base/src/Lhc/Num.hs +21/−1
- lib/base/src/Lhc/Order.hs +75/−5
- lib/base/src/Lhc/Order.m4 +16/−22
- lib/base/src/Lhc/Prim.hs +15/−1
- lib/base/src/Lhc/Types.hs +3/−0
- lib/base/src/Prelude/Float.hs +1/−1
- lib/base/src/System.hs +7/−7
- lib/base/src/System/IO.hs +4/−2
- src/C/FromGrin2.hs +9/−5
- src/C/Generate.hs +1/−1
- src/DataConstructors.hs +48/−39
- src/DataConstructors.hs-boot +1/−1
- src/Doc/DocLike.hs +2/−2
- src/E/Annotate.hs +4/−4
- src/E/Binary.hs +5/−18
- src/E/Demand.hs +1/−4
- src/E/E.hs +2/−2
- src/E/Eta.hs +3/−3
- src/E/Eval.hs +15/−4
- src/E/FreeVars.hs +1/−1
- src/E/FromHs.hs +21/−14
- src/E/LambdaLift.hs +3/−3
- src/E/LetFloat.hs +2/−2
- src/E/PrimOpt.hs +1/−1
- src/E/Program.hs +13/−3
- src/E/Rules.hs +22/−11
- src/E/SSimplify.hs +47/−17
- src/E/Show.hs +11/−6
- src/E/Subst.hs +11/−11
- src/E/Traverse.hs +8/−3
- src/E/Type.hs +3/−3
- src/E/TypeAnalysis.hs +2/−2
- src/E/TypeCheck.hs +14/−14
- src/E/Values.hs +22/−8
- src/E/WorkerWrapper.hs +2/−1
- src/Fixer/Fixer.hs +27/−5
- src/FlagDump.hs +7/−3
- src/FlagOpts.hs +6/−6
- src/FrontEnd/Class.hs +97/−120
- src/FrontEnd/DataConsAssump.hs +2/−2
- src/FrontEnd/DeclsDepends.hs +13/−13
- src/FrontEnd/HsParser.y +2/−1
- src/FrontEnd/HsSyn.hs +1/−1
- src/FrontEnd/Infix.hs +2/−3
- src/FrontEnd/KindInfer.hs +19/−11
- src/FrontEnd/Rename.hs +1/−3
- src/FrontEnd/Representation.hs +15/−2
- src/FrontEnd/Tc/Kind.hs +2/−0
- src/FrontEnd/Tc/Main.hs +10/−2
- src/FrontEnd/Tc/Module.hs +8/−4
- src/FrontEnd/Tc/Monad.hs +5/−4
- src/FrontEnd/Tc/Type.hs +4/−1
- src/FrontEnd/Tc/Unify.hs +3/−3
- src/FrontEnd/TypeSynonyms.hs +2/−3
- src/FrontEnd/TypeSyns.hs +3/−3
- src/Grin/DeadCode.hs +6/−12
- src/Grin/FromE.hs +76/−13
- src/Grin/Grin.hs +11/−9
- src/Grin/Lint.hs +2/−2
- src/Grin/Show.hs +5/−5
- src/Ho/Binary.hs +5/−6
- src/Ho/Build.hs +29/−1
- src/Ho/Type.hs +0/−1
- src/LHCVersion.hs +1/−1
- src/Main.hs +24/−16
- src/Name/Binary.hs +0/−29
- src/Name/Id.hs +104/−44
- src/Name/Name.hs +60/−27
- src/Name/Prim.hs +33/−23
- src/Options.hs +1/−1
- src/PrimitiveOperators.hs +61/−56
- src/Stats.hs +2/−4
- src/Support/MapBinaryInstance.hs +0/−39
- src/Util/NameMonad.hs +7/−1
- src/Util/TrueSet.hs +0/−60
data/names.txt view
@@ -28,6 +28,9 @@ Bits128 Lhc.Types.Bits128_ BitsPtr Lhc.Types.BitsPtr_ BitsMax Lhc.Types.BitsMax_+BitsSize Lhc.Types.BitsSize_t_+BitsShort Lhc.Types.BitsShort_+BitsInt Lhc.Types.BitsInt_ Float32 Lhc.Types.Float32_ Float64 Lhc.Types.Float64_
data/rts/lhc_rts2.c view
@@ -162,7 +162,6 @@ if(ds->head == BLACK_HOLE) return 1; assert(GETTAG(ds->head) == P_FUNC); fptr_t dhead = (fptr_t)DETAG(ds->head);- assert(dhead >= &_start && dhead < &_end); return 1; } else return lhc_valid_whnf((wptr_t)ds->head);
data/rts/lhc_rts_alloc.c view
@@ -7,8 +7,6 @@ #define lhc_malloc_atomic_whnf lhc_malloc_atomic #define lhc_malloc_sanity(p,t) (1) -extern void _start,_end;- #if _LHC_PROFILE #define BUCKETS 7
dist/build/lhc/lhc-tmp/FrontEnd/HsParser.hs view
@@ -2020,7 +2020,8 @@ 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- , hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" }+ , hsRuleIsMeta = error "hsRuleIsMeta not set"+ , hsRuleIsMethod = False } ) `HappyStk` happyRest}}}}} happyReduce_83 = happySpecReduce_3 29# happyReduction_83
lhc-regress/Main.hs view
@@ -19,7 +19,7 @@ import qualified Data.ByteString.Char8 as B data TestResult = CompileError String- | ProgramError String+ | ProgramError String String | KnownFailure | TimeOut | Success@@ -29,6 +29,45 @@ isSuccess KnownFailure = True isSuccess _ = False +data Stats = Stats { successfulTests :: Int+ , expectedFailures :: Int+ , unexpectedFailures :: Int+ , testsNotExecuted :: Int+ }++newStats :: Int -> Stats+newStats nTests = Stats 0 0 0 nTests++successfulTest :: Stats -> Stats+successfulTest stats = stats{ successfulTests = successfulTests stats + 1+ , testsNotExecuted = testsNotExecuted stats - 1 }++expectedFailure :: Stats -> Stats+expectedFailure stats = stats{ expectedFailures = expectedFailures stats + 1+ , testsNotExecuted = testsNotExecuted stats - 1 }++unexpectedFailure :: Stats -> Stats+unexpectedFailure stats = stats{ unexpectedFailures = unexpectedFailures stats + 1+ , testsNotExecuted = testsNotExecuted stats - 1 }++hasFailures :: Stats -> Bool+hasFailures stats = unexpectedFailures stats /= 0++ppStats :: Stats -> String+ppStats stats = printf ("Successful tests: %d\n"+++ "Expected failures: %d\n"+++ "Unexpected failures: %d\n"+++ "Omitted tests: %d\n")+ (successfulTests stats)+ (expectedFailures stats)+ (unexpectedFailures stats)+ (testsNotExecuted stats)++updateStats :: TestResult -> Stats -> Stats+updateStats Success = successfulTest+updateStats KnownFailure = expectedFailure+updateStats _ = unexpectedFailure+ main :: IO () main = do (cfg,paths) <- parseArguments =<< getArgs workChan <- newChan@@ -43,33 +82,37 @@ writeChan resultChan (test,result) results <- getChanContents resultChan- manager cfg True (take nTests results)+ manager cfg (newStats nTests) (take nTests results) `finally` mapM_ killThread workers errMsg = "Some tests failed to perform as expected." -manager cfg False _ | not (cfgComplete cfg)- = do when (cfgVerbose cfg >= 1) $ putStrLn errMsg+manager cfg stats rest | hasFailures stats && (not (cfgComplete cfg) || null rest)+ = do when (cfgVerbose cfg == 1) $ putStrLn ""+ when (cfgVerbose cfg >= 1) $ do putStrLn errMsg+ putStr (ppStats stats) exitFailure -manager cfg True [] | cfgVerbose cfg >= 3 = putStrLn "No unexpected failures"-manager cfg True [] | cfgVerbose cfg >= 1 = putStrLn ""-manager cfg True [] = return ()-manager cfg False [] = do when (cfgVerbose cfg >= 1) $ putStrLn errMsg >> exitFailure- exitFailure+manager cfg stats [] | cfgVerbose cfg >= 3 = do putStrLn "No unexpected failures"+ putStr (ppStats stats)+manager cfg stats [] | cfgVerbose cfg >= 1 = do putStrLn ""+ putStr (ppStats stats)+manager cfg stats [] = return () -manager cfg noFailures ((tc,result):rest)+manager cfg stats ((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+ Success -> printf "%20s: %s\n" (testCaseName tc) "OK."+ KnownFailure -> printf "%20s: %s\n" (testCaseName tc) "Known failure."+ TimeOut -> printf "%20s: %s\n" (testCaseName tc) "TimeOut."+ CompileError str | cfgVerbose cfg >= 4 -> printf "%20s: %s\n" (testCaseName tc) str+ ProgramError short str | cfgVerbose cfg >= 4 -> printf "%20s: %s:\n%s" (testCaseName tc) short str+ CompileError str -> printf "%20s: %s\n" (testCaseName tc) "Compile failure."+ ProgramError short str -> printf "%20s: %s\n" (testCaseName tc) short | cfgVerbose cfg >= 1 -> if isSuccess result then putStr "." else putStr "*" | otherwise -> return () hFlush stdout- manager cfg (noFailures && isSuccess result) rest+ manager cfg (updateStats result stats) rest -- FIXME: Get a proper temporary directory. runTestCase :: Config -> TestCase -> IO TestResult@@ -78,6 +121,7 @@ (\_ -> removeDirectoryRecursive testDir) $ \_ -> checkFail $ withTimeout $ do let args = [ "-o", progName , "--ho-dir", testDir+ , "-flint" , testCasePath tc ] ++ cfgLHCOptions cfg when (cfgVerbose cfg >= 4) $ putStrLn $ unwords (cfgLHCPath cfg:args)@@ -88,8 +132,8 @@ -> 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]+ (Just expectedOut,_) | expectedOut /= out -> return $ ProgramError "Unexpected stdout" $ B.unpack out+ (_,Just expectedErr) | expectedErr /= err -> return $ ProgramError "Unexpected stderr" $ B.unpack err _ -> return Success where name = dropExtension (takeFileName (testCasePath tc)) testDir = cfgTempDir cfg </> name@@ -97,7 +141,7 @@ checkFail io = do ret <- io if testCaseMustFail tc then case ret of- Success -> return $ ProgramError "Known bug succeeded."+ Success -> return $ ProgramError "Known bug succeeded." "" other -> return KnownFailure else return ret withTimeout io = do ret <- timeout (10^6 * cfgTestTimeout cfg) io
lhc.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.6 name: lhc-version: 0.6.20081216+version: 0.6.20090126 synopsis: LHC Haskell Compiler description: lhc is a haskell compiler which aims to produce the most efficient programs possible via whole@@ -17,6 +17,7 @@ extra-source-files: lib/base/base.cabal, lib/base/Setup.hs, lib/base/src/Control/*.hs,+ lib/base/src/Control/Monad/*.hs, lib/base/src/Data/Array/*.hs, lib/base/src/Data/*.hs, lib/base/src/Debug/*.hs,@@ -24,8 +25,9 @@ lib/base/src/Foreign/Marshal/*.hs, lib/base/src/Foreign/*.hs, lib/base/src/Foreign/Storable.m4,+ lib/base/src/Lhc/*.hs lib/base/src/Lhc/Inst/*.hs,- lib/base/src/Lhc/*.hs,+ lib/base/src/Lhc/Inst/Num.m4 lib/base/src/Lhc/Order.m4, lib/base/src/Lhc/Text/*.hs, lib/base/src/Prelude/*.hs,@@ -98,13 +100,13 @@ Grin.HashConst Grin.Interpret Grin.Lint Grin.NodeAnalyze Grin.Noodle Grin.Optimize Grin.SSimplify Grin.Show Grin.Simplify Grin.Unboxing Grin.Val Grin.Whiz Ho.Collected Ho.Binary Ho.Build Ho.Library Ho.Type Info.Binary Info.Info Info.Types Info.Properties- Name.Prim Name.Binary Name.Id Name.Name Name.Names Name.VConsts+ Name.Prim Name.Id Name.Name Name.Names Name.VConsts Support.Tuple Support.CFF Support.FreeVars Support.CanType Support.ShowTable- Support.Tickle Support.Transform Support.Unparse Support.MapBinaryInstance Util.Graph+ Support.Tickle Support.Transform Support.Unparse Util.Graph Util.Gen Util.ArbitraryInstances Util.BitSet Util.BooleanSolver Util.ContextMonad Util.FilterInput Util.ReaderWriter Util.Graphviz Util.HasSize Util.Histogram 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.RWS Util.Relation Util.SameShape Util.Seq Util.SetLike Util.UnionFind Util.UnionSolve Util.UniqueMonad Util.VarName Util.Util LHCVersion Executable lhc-regress
lib/base/base.cabal view
@@ -6,43 +6,50 @@ Library Extensions: ForeignFunctionInterface hs-source-dirs: src- Exposed-Modules: Control.Exception,- Control.Monad,- Data.Array,+ Exposed-Modules:+ Control.Exception+ Control.Applicative+ Control.Arrow+ Control.Category+ Control.Monad+ Control.Monad.Fix+ Control.Monad.Instances+ Data.Array Data.Char,- Data.Complex,- Data.List,+ Data.Complex+ Data.List Data.Word,- Data.Monoid,- Data.Bits,- Data.Int,- Data.IORef,- Data.Ix,- Data.Maybe,+ Data.Monoid+ Data.Bits+ Data.Int+ Data.IORef+ Data.Ix+ Data.Maybe Data.Ratio,- Data.Unicode,- Debug.Trace,- Foreign,- Foreign.C,+ Data.Unicode+ Data.Function+ Debug.Trace+ Foreign+ Foreign.C Foreign.C.Types, Foreign.C.String, Foreign.C.Error,- Foreign.ForeignPtr,+ Foreign.ForeignPtr Foreign.Marshal Foreign.Marshal.Alloc, Foreign.Marshal.Array, Foreign.Marshal.Error,- Foreign.Marshal.Pool,+ Foreign.Marshal.Pool Foreign.Marshal.Utils, Foreign.Ptr,- Foreign.StablePtr,+ Foreign.StablePtr Foreign.Storable, Lhc.Addr, Lhc.Basics, Lhc.Float- Lhc.Array,- Data.Array.IO,- Data.Array.Unboxed,+ Lhc.Array+ Data.Array.IO+ Data.Array.Unboxed Lhc.Handle, Lhc.IO, Lhc.Tuples,@@ -51,18 +58,18 @@ Prelude.IO, Prelude.IOError, Prelude.Text,- Prelude,- System.Console.GetOpt,- System.CPUTime,- System.Directory,- System.Info,- System.IO,- System.IO.Error,+ Prelude+ System.Console.GetOpt+ System.CPUTime+ System.Directory+ System.Info+ System.IO+ System.IO.Error System.IO.Unsafe,- System.IO.Binary,- System.Locale,- System.Random,- System.Time,+ System.IO.Binary+ System.Locale+-- System.Random,+-- System.Time, System Text.Show.Functions Text.Printf
+ lib/base/src/Control/Applicative.hs view
@@ -0,0 +1,220 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Applicative+-- Copyright : Conor McBride and Ross Paterson 2005+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ross@soi.city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- This module describes a structure intermediate between a functor and+-- a monad: it provides pure expressions and sequencing, but no binding.+-- (Technically, a strong lax monoidal functor.) For more details, see+-- /Applicative Programming with Effects/,+-- by Conor McBride and Ross Paterson, online at+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+-- This interface was introduced for parsers by Niklas Röjemo, because+-- it admits more sharing than the monadic interface. The names here are+-- mostly based on recent parsing work by Doaitse Swierstra.+--+-- This class is also useful with instances of the+-- 'Data.Traversable.Traversable' class.++module Control.Applicative (+ -- * Applicative functors+ Applicative(..),+ -- * Alternatives+ Alternative(..),+ -- * Instances+ Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),+ -- * Utility functions+ (<$>), (<$), (*>), (<*), (<**>),+ liftA, liftA2, liftA3,+ optional, some, many+ ) where++import Prelude hiding (id,(.))+import qualified Prelude++import Control.Category+import Control.Arrow+ (Arrow(arr, (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>)))+import Control.Monad (liftM, ap, MonadPlus(..))+import Control.Monad.Instances ()+import Data.Monoid (Monoid(..))++infixl 3 <|>+infixl 4 <$>, <$+infixl 4 <*>, <*, *>, <**>++-- | A functor with application.+--+-- Instances should satisfy the following laws:+--+-- [/identity/]+-- @'pure' 'id' '<*>' v = v@+--+-- [/composition/]+-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@+--+-- [/homomorphism/]+-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@+--+-- [/interchange/]+-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@+--+-- The 'Functor' instance should satisfy+--+-- @+-- 'fmap' f x = 'pure' f '<*>' x+-- @+--+-- If @f@ is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@.++class Functor f => Applicative f where+ -- | Lift a value.+ pure :: a -> f a++ -- | Sequential application.+ (<*>) :: f (a -> b) -> f a -> f b++-- | A monoid on applicative functors.+class Applicative f => Alternative f where+ -- | The identity of '<|>'+ empty :: f a+ -- | An associative binary operation+ (<|>) :: f a -> f a -> f a++-- instances for Prelude types++instance Applicative Maybe where+ pure = return+ (<*>) = ap++instance Alternative Maybe where+ empty = Nothing+ Nothing <|> p = p+ Just x <|> _ = Just x++instance Applicative [] where+ pure = return+ (<*>) = ap++instance Alternative [] where+ empty = []+ (<|>) = (++)++instance Applicative IO where+ pure = return+ (<*>) = ap++instance Applicative ((->) a) where+ pure = const+ (<*>) f g x = f x (g x)++instance Monoid a => Applicative ((,) a) where+ pure x = (mempty, x)+ (u, f) <*> (v, x) = (u `mappend` v, f x)++-- new instances++newtype Const a b = Const { getConst :: a }++instance Functor (Const m) where+ fmap _ (Const v) = Const v++instance Monoid m => Applicative (Const m) where+ pure _ = Const mempty+ Const f <*> Const v = Const (f `mappend` v)++newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }++instance Monad m => Functor (WrappedMonad m) where+ fmap f (WrapMonad v) = WrapMonad (liftM f v)++instance Monad m => Applicative (WrappedMonad m) where+ pure = WrapMonad . return+ WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v)++instance MonadPlus m => Alternative (WrappedMonad m) where+ empty = WrapMonad mzero+ WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v)++newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c }++instance Arrow a => Functor (WrappedArrow a b) where+ fmap f (WrapArrow a) = WrapArrow (a >>> arr f)++instance Arrow a => Applicative (WrappedArrow a b) where+ pure x = WrapArrow (arr (const x))+ WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id))++instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where+ empty = WrapArrow zeroArrow+ WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)++-- | Lists, but with an 'Applicative' functor based on zipping, so that+--+-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@+--+newtype ZipList a = ZipList { getZipList :: [a] }++instance Functor ZipList where+ fmap f (ZipList xs) = ZipList (map f xs)++instance Applicative ZipList where+ pure x = ZipList (repeat x)+ ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)++-- extra functions++-- | A synonym for 'fmap'.+(<$>) :: Functor f => (a -> b) -> f a -> f b+f <$> a = fmap f a++-- | Replace the value.+(<$) :: Functor f => a -> f b -> f a+(<$) = (<$>) . const+ +-- | Sequence actions, discarding the value of the first argument.+(*>) :: Applicative f => f a -> f b -> f b+(*>) = liftA2 (const id)+ +-- | Sequence actions, discarding the value of the second argument.+(<*) :: Applicative f => f a -> f b -> f a+(<*) = liftA2 const+ +-- | A variant of '<*>' with the arguments reversed.+(<**>) :: Applicative f => f a -> f (a -> b) -> f b+(<**>) = liftA2 (flip ($))++-- | Lift a function to actions.+-- This function may be used as a value for `fmap` in a `Functor` instance.+liftA :: Applicative f => (a -> b) -> f a -> f b+liftA f a = pure f <*> a++-- | Lift a binary function to actions.+liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c+liftA2 f a b = f <$> a <*> b++-- | Lift a ternary function to actions.+liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d+liftA3 f a b c = f <$> a <*> b <*> c++-- | One or none.+optional :: Alternative f => f a -> f (Maybe a)+optional v = Just <$> v <|> pure Nothing++-- | One or more.+some :: Alternative f => f a -> f [a]+some v = some_v+ where many_v = some_v <|> pure []+ some_v = (:) <$> v <*> many_v++-- | Zero or more.+many :: Alternative f => f a -> f [a]+many v = many_v+ where many_v = some_v <|> pure []+ some_v = (:) <$> v <*> many_v
+ lib/base/src/Control/Arrow.hs view
@@ -0,0 +1,278 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Arrow+-- Copyright : (c) Ross Paterson 2002+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ross@soi.city.ac.uk+-- Stability : experimental+-- Portability : portable+--+-- Basic arrow definitions, based on+-- /Generalising Monads to Arrows/, by John Hughes,+-- /Science of Computer Programming/ 37, pp67-111, May 2000.+-- plus a couple of definitions ('returnA' and 'loop') from+-- /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,+-- Firenze, Italy, pp229-240.+-- See these papers for the equations these combinators are expected to+-- satisfy. These papers and more information on arrows can be found at+-- <http://www.haskell.org/arrows/>.++module Control.Arrow (+ -- * Arrows+ Arrow(..), Kleisli(..),+ -- ** Derived combinators+ returnA,+ (^>>), (>>^),+ -- ** Right-to-left variants+ (<<^), (^<<),+ -- * Monoid operations+ ArrowZero(..), ArrowPlus(..),+ -- * Conditionals+ ArrowChoice(..),+ -- * Arrow application+ ArrowApply(..), ArrowMonad(..), leftApp,+ -- * Feedback+ ArrowLoop(..)+ ) where++import Prelude hiding (id,(.))+import qualified Prelude++import Control.Monad+import Control.Monad.Fix+import Control.Category++infixr 5 <+>+infixr 3 ***+infixr 3 &&&+infixr 2 ++++infixr 2 |||+infixr 1 ^>>, >>^+infixr 1 ^<<, <<^++-- | The basic arrow class.+-- Any instance must define either 'arr' or 'pure' (which are synonyms),+-- as well as 'first'. The other combinators have sensible+-- default definitions, which may be overridden for efficiency.++class Category a => Arrow a where++ -- | Lift a function to an arrow: you must define either this+ -- or 'pure'.+ arr :: (b -> c) -> a b c+ arr = pure++ -- | A synonym for 'arr': you must define one or other of them.+ pure :: (b -> c) -> a b c+ pure = arr++ -- | Send the first component of the input through the argument+ -- arrow, and copy the rest unchanged to the output.+ first :: a b c -> a (b,d) (c,d)++ -- | A mirror image of 'first'.+ --+ -- The default definition may be overridden with a more efficient+ -- version if desired.+ second :: a b c -> a (d,b) (d,c)+ second f = arr swap >>> first f >>> arr swap+ where swap ~(x,y) = (y,x)++ -- | Split the input between the two argument arrows and combine+ -- their output. Note that this is in general not a functor.+ --+ -- The default definition may be overridden with a more efficient+ -- version if desired.+ (***) :: a b c -> a b' c' -> a (b,b') (c,c')+ f *** g = first f >>> second g++ -- | Fanout: send the input to both argument arrows and combine+ -- their output.+ --+ -- The default definition may be overridden with a more efficient+ -- version if desired.+ (&&&) :: a b c -> a b c' -> a b (c,c')+ f &&& g = arr (\b -> (b,b)) >>> f *** g++{-# RULES "identity" arr id = id+ "compose/arr" forall f g .+ (arr f) . (arr g) = arr (f . g)+ "first/arr" forall f .+ first (arr f) = arr (first f)+ "second/arr" forall f .+ second (arr f) = arr (second f)+ "product/arr" forall f g .+ arr f *** arr g = arr (f *** g)+ "fanout/arr" forall f g .+ arr f &&& arr g = arr (f &&& g)+ "compose/first" forall f g .+ (first f) . (first g) = first (f . g)+ "compose/second" forall f g .+ (second f) . (second g) = second (f . g)+ #-}++-- Ordinary functions are arrows.++instance Arrow (->) where+ arr f = f+ first f = f *** id+ second f = id *** f+-- (f *** g) ~(x,y) = (f x, g y)+-- sorry, although the above defn is fully H'98, nhc98 can't parse it.+ (***) f g ~(x,y) = (f x, g y)++-- | Kleisli arrows of a monad.++newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }++instance Monad m => Category (Kleisli m) where+ id = Kleisli return+ (Kleisli f) . (Kleisli g) = Kleisli (\b -> g b >>= f)++instance Monad m => Arrow (Kleisli m) where+ arr f = Kleisli (return . f)+ first (Kleisli f) = Kleisli (\ ~(b,d) -> f b >>= \c -> return (c,d))+ second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))++-- | The identity arrow, which plays the role of 'return' in arrow notation.++returnA :: Arrow a => a b b+returnA = arr id++-- | Precomposition with a pure function.+(^>>) :: Arrow a => (b -> c) -> a c d -> a b d+f ^>> a = arr f >>> a++-- | Postcomposition with a pure function.+(>>^) :: Arrow a => a b c -> (c -> d) -> a b d+a >>^ f = a >>> arr f++-- | Precomposition with a pure function (right-to-left variant).+(<<^) :: Arrow a => a c d -> (b -> c) -> a b d+a <<^ f = a <<< arr f++-- | Postcomposition with a pure function (right-to-left variant).+(^<<) :: Arrow a => (c -> d) -> a b c -> a b d+f ^<< a = arr f <<< a++class Arrow a => ArrowZero a where+ zeroArrow :: a b c++instance MonadPlus m => ArrowZero (Kleisli m) where+ zeroArrow = Kleisli (\x -> mzero)++class ArrowZero a => ArrowPlus a where+ (<+>) :: a b c -> a b c -> a b c++instance MonadPlus m => ArrowPlus (Kleisli m) where+ Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)++-- | Choice, for arrows that support it. This class underlies the+-- @if@ and @case@ constructs in arrow notation.+-- Any instance must define 'left'. The other combinators have sensible+-- default definitions, which may be overridden for efficiency.++class Arrow a => ArrowChoice a where++ -- | Feed marked inputs through the argument arrow, passing the+ -- rest through unchanged to the output.+ left :: a b c -> a (Either b d) (Either c d)++ -- | A mirror image of 'left'.+ --+ -- The default definition may be overridden with a more efficient+ -- version if desired.+ right :: a b c -> a (Either d b) (Either d c)+ right f = arr mirror >>> left f >>> arr mirror+ where mirror (Left x) = Right x+ mirror (Right y) = Left y++ -- | Split the input between the two argument arrows, retagging+ -- and merging their outputs.+ -- Note that this is in general not a functor.+ --+ -- The default definition may be overridden with a more efficient+ -- version if desired.+ (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')+ f +++ g = left f >>> right g++ -- | Fanin: Split the input between the two argument arrows and+ -- merge their outputs.+ --+ -- The default definition may be overridden with a more efficient+ -- version if desired.+ (|||) :: a b d -> a c d -> a (Either b c) d+ f ||| g = f +++ g >>> arr untag+ where untag (Left x) = x+ untag (Right y) = y++{-# RULES+ "left/arr" forall f .+ left (arr f) = arr (left f)+ "right/arr" forall f .+ right (arr f) = arr (right f)+ "sum/arr" forall f g .+ arr f +++ arr g = arr (f +++ g)+ "fanin/arr" forall f g .+ arr f ||| arr g = arr (f ||| g)+ "compose/left" forall f g .+ left f >>> left g = left (f >>> g)+ "compose/right" forall f g .+ right f >>> right g = right (f >>> g)+ #-}++instance ArrowChoice (->) where+ left f = f +++ id+ right f = id +++ f+ f +++ g = (Left . f) ||| (Right . g)+ (|||) = either++instance Monad m => ArrowChoice (Kleisli m) where+ left f = f +++ arr id+ right f = arr id +++ f+ f +++ g = (f >>> arr Left) ||| (g >>> arr Right)+ Kleisli f ||| Kleisli g = Kleisli (either f g)++-- | Some arrows allow application of arrow inputs to other inputs.++class Arrow a => ArrowApply a where+ app :: a (a b c, b) c++instance ArrowApply (->) where+ app (f,x) = f x++instance Monad m => ArrowApply (Kleisli m) where+ app = Kleisli (\(Kleisli f, x) -> f x)++-- | The 'ArrowApply' class is equivalent to 'Monad': any monad gives rise+-- to a 'Kleisli' arrow, and any instance of 'ArrowApply' defines a monad.++newtype ArrowApply a => ArrowMonad a b = ArrowMonad (a () b)++instance ArrowApply a => Monad (ArrowMonad a) where+ return x = ArrowMonad (arr (\z -> x))+ ArrowMonad m >>= f = ArrowMonad (m >>>+ arr (\x -> let ArrowMonad h = f x in (h, ())) >>>+ app)++-- | Any instance of 'ArrowApply' can be made into an instance of+-- 'ArrowChoice' by defining 'left' = 'leftApp'.++leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)+leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||+ (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app++-- | The 'loop' operator expresses computations in which an output value is+-- fed back as input, even though the computation occurs only once.+-- It underlies the @rec@ value recursion construct in arrow notation.++class Arrow a => ArrowLoop a where+ loop :: a (b,d) (c,d) -> a b c++instance ArrowLoop (->) where+ loop f b = let (c,d) = f (b,d) in c++instance MonadFix m => ArrowLoop (Kleisli m) where+ loop (Kleisli f) = Kleisli (liftM fst . mfix . f')+ where f' x y = f (x, snd y)
+ lib/base/src/Control/Category.hs view
@@ -0,0 +1,53 @@+{-# LHC_OPTIONS -fcpp -N #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Category+-- Copyright : (c) Ashley Yakeley 2007+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : ashley@semantic.org+-- Stability : experimental+-- Portability : portable++-- http://hackage.haskell.org/trac/ghc/ticket/1773++module Control.Category where++import Lhc.Basics hiding (id,(.))+import qualified Lhc.Basics as Prelude++infixr 9 .+infixr 1 >>>, <<<++-- | A class for categories.+-- id and (.) must form a monoid.+class Category cat where+ -- | the identity morphism+ id :: cat a a++ -- | morphism composition+ (.) :: cat b c -> cat a b -> cat a c++{-# RULES+ "identity/left" forall p .+ id . p = p+ "identity/right" forall p .+ p . id = p+ "association" forall p q r .+ (p . q) . r = p . (q . r)+ #-}++instance Category (->) where+ id = Prelude.id+#ifndef __HADDOCK__+-- Haddock 1.x cannot parse this:+ (.) = (Prelude..)+#endif++-- | Right-to-left composition+(<<<) :: Category cat => cat b c -> cat a b -> cat a c+(<<<) = (.)++-- | Left-to-right composition+(>>>) :: Category cat => cat a b -> cat b c -> cat a c+f >>> g = g . f
+ lib/base/src/Control/Monad/Fix.hs view
@@ -0,0 +1,80 @@+{-# LHC_OPTIONS -fcpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Fix+-- Copyright : (c) Andy Gill 2001,+-- (c) Oregon Graduate Institute of Science and Technology, 2002+-- License : BSD-style (see the file libraries/base/LICENSE)+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Monadic fixpoints.+--+-- For a detailed discussion, see Levent Erkok's thesis,+-- /Value Recursion in Monadic Computations/, Oregon Graduate Institute, 2002.+--+-----------------------------------------------------------------------------++module Control.Monad.Fix (+ MonadFix(+ mfix -- :: (a -> m a) -> m a+ ),+ fix -- :: (a -> a) -> a+ ) where++import Prelude+import System.IO+import Control.Monad.Instances ()+import Data.Function (fix)+#ifdef __HUGS__+import Hugs.Prelude (MonadFix(mfix))+#endif++#ifndef __HUGS__+-- | Monads having fixed points with a \'knot-tying\' semantics.+-- Instances of 'MonadFix' should satisfy the following laws:+--+-- [/purity/]+-- @'mfix' ('return' . h) = 'return' ('fix' h)@+--+-- [/left shrinking/ (or /tightening/)]+-- @'mfix' (\\x -> a >>= \\y -> f x y) = a >>= \\y -> 'mfix' (\\x -> f x y)@+--+-- [/sliding/]+-- @'mfix' ('Control.Monad.liftM' h . f) = 'Control.Monad.liftM' h ('mfix' (f . h))@,+-- for strict @h@.+--+-- [/nesting/]+-- @'mfix' (\\x -> 'mfix' (\\y -> f x y)) = 'mfix' (\\x -> f x x)@+--+-- This class is used in the translation of the recursive @do@ notation+-- supported by GHC and Hugs.+class (Monad m) => MonadFix m where+ -- | The fixed point of a monadic computation.+ -- @'mfix' f@ executes the action @f@ only once, with the eventual+ -- output fed back as the input. Hence @f@ should not be strict,+ -- for then @'mfix' f@ would diverge.+ mfix :: (a -> m a) -> m a+#endif /* !__HUGS__ */++-- Instances of MonadFix for Prelude monads++-- Maybe:+instance MonadFix Maybe where+ mfix f = let a = f (unJust a) in a+ where unJust (Just x) = x++-- List:+instance MonadFix [] where+ mfix f = case fix (f . head) of+ [] -> []+ (x:_) -> x : mfix (tail . f)++-- IO:+instance MonadFix IO where+ mfix = fixIO ++instance MonadFix ((->) r) where+ mfix f = \ r -> let a = f a r in a+
+ lib/base/src/Control/Monad/Instances.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_NHC98 --prelude #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Instances+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- 'Functor' and 'Monad' instances for @(->) r@ and+-- 'Functor' instances for @(,) a@ and @'Either' a@.++module Control.Monad.Instances (Functor(..),Monad(..)) where++import Prelude++instance Functor ((->) r) where+ fmap = (.)++instance Monad ((->) r) where+ return = const+ f >>= k = \ r -> k (f r) r++instance Functor ((,) a) where+ fmap f (x,y) = (x, f y)++instance Functor (Either a) where+ fmap _ (Left x) = Left x+ fmap f (Right y) = Right (f y)
lib/base/src/Data/Bits.hs view
@@ -1,11 +1,12 @@-{-# OPTIONS_LHC -N #-}+{-# OPTIONS_LHC -N -fffi -fm4 #-} module Data.Bits where import Lhc.Num import Lhc.Order-import Lhc.Int-+import Lhc.Types+import Data.Int+import Lhc.Prim infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR` infixl 7 .&.@@ -140,3 +141,22 @@ x `rotateR` i = x `rotate` (-i) +m4_define(INST_BITS,{{+instance Bits $1 where+ $1 x .&. $1 y = $1 (and$1 x y)+ $1 x .|. $1 y = $1 (or$1 x y)+ $1 x `xor` $1 y = $1 (xor$1 x y)+ complement ($1 x) = $1 (complement$1 x)+ shiftL ($1 x) (Int bits) = $1 (shiftL$1 x bits)+ shiftR ($1 x) (Int bits) = $1 (shiftR$1 x bits)++foreign import primitive "And" and$1 :: $2 -> $2 -> $2+foreign import primitive "Or" or$1 :: $2 -> $2 -> $2+foreign import primitive "Xor" xor$1 :: $2 -> $2 -> $2+foreign import primitive "Com" complement$1 :: $2 -> $2+foreign import primitive "Shl" shiftL$1 :: $2 -> Bits32_ -> $2+foreign import primitive "Shra" shiftR$1 :: $2 -> Bits32_ -> $2++}})++INST_BITS(Int,Bits32_)
+ lib/base/src/Data/Function.hs view
@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Function+-- Copyright : Nils Anders Danielsson 2006+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Simple combinators working solely on and with functions.++module Data.Function+ ( -- * "Prelude" re-exports+ id, const, (.), flip, ($)+ -- * Other combinators+ , fix+ , on+ ) where++import Prelude++infixl 0 `on`++-- | @'fix' f@ is the least fixed point of the function @f@,+-- i.e. the least defined @x@ such that @f x = x@.+fix :: (a -> a) -> a+fix f = let x = f x in x++-- | @(*) \`on\` f = \\x y -> f x * f y@.+--+-- Typical usage: @'Data.List.sortBy' ('compare' \`on\` 'fst')@.+--+-- Algebraic properties:+--+-- * @(*) \`on\` 'id' = (*)@ (if @(*) ∉ {⊥, 'const' ⊥}@)+--+-- * @((*) \`on\` f) \`on\` g = (*) \`on\` (f . g)@+--+-- * @'flip' on f . 'flip' on g = 'flip' on (g . f)@++-- Proofs (so that I don't have to edit the test-suite):++-- (*) `on` id+-- =+-- \x y -> id x * id y+-- =+-- \x y -> x * y+-- = { If (*) /= _|_ or const _|_. }+-- (*)++-- (*) `on` f `on` g+-- =+-- ((*) `on` f) `on` g+-- =+-- \x y -> ((*) `on` f) (g x) (g y)+-- =+-- \x y -> (\x y -> f x * f y) (g x) (g y)+-- =+-- \x y -> f (g x) * f (g y)+-- =+-- \x y -> (f . g) x * (f . g) y+-- =+-- (*) `on` (f . g)+-- =+-- (*) `on` f . g++-- flip on f . flip on g+-- =+-- (\h (*) -> (*) `on` h) f . (\h (*) -> (*) `on` h) g+-- =+-- (\(*) -> (*) `on` f) . (\(*) -> (*) `on` g)+-- =+-- \(*) -> (*) `on` g `on` f+-- = { See above. }+-- \(*) -> (*) `on` g . f+-- =+-- (\h (*) -> (*) `on` h) (g . f)+-- =+-- flip on (g . f)++on :: (b -> b -> c) -> (a -> b) -> a -> a -> c+(*) `on` f = \x y -> f x * f y
lib/base/src/Data/Int.hs view
@@ -1,11 +1,5 @@ {-# OPTIONS_LHC -N #-} module Data.Int(Int,Int8,Int16,Int32,Int64,IntMax,IntPtr) where -import Lhc.Prim(Int())+import Lhc.Prim -data Int8-data Int16-data Int32-data Int64-data IntMax-data IntPtr
lib/base/src/Data/Word.hs view
@@ -1,12 +1,5 @@ {-# OPTIONS -N #-} module Data.Word(Word,Word8,Word16,Word32,Word64,WordMax,WordPtr) where -+import Lhc.Prim -data Word-data Word8-data Word16-data Word32-data Word64-data WordMax-data WordPtr
lib/base/src/Foreign/C/Types.hs view
@@ -1,18 +1,37 @@-{-# OPTIONS --noprelude #-}-module Foreign.C.Types where+{-# OPTIONS --noprelude -fffi -fm4 -funboxed-tuples -funboxed-values #-}+module Foreign.C.Types+ ( CChar(..)+ , CInt(..)+ , CWchar(..)+ , CWint+ , CSize+ ) where -data CChar+-- FIXME: this module really shouldn't import all this stuff. These types should probably+-- be defined in another module so that instances can be defined elsewhere.++import Lhc.Types+import Lhc.Num+import Lhc.Order+import Lhc.Prim+import Lhc.Basics+import Foreign.Storable+import Lhc.IO+import Lhc.Int+import Lhc.Addr++data CChar = CChar Bits8_ data CSChar data CUChar-data CShort+data CShort = CShort BitsShort_ data CUShort-data CInt+data CInt = CInt BitsInt_ data CUInt data CLong data CULong data CPtrdiff-data CSize-data CWchar+data CSize = CSize BitsSize_t_+data CWchar = CWchar Bits32_ data CSigAtomic data CLLong data CULLong@@ -24,4 +43,26 @@ data CFile data CJmpBuf data CFpos-data CWint+data CWint = CWint Bits32_++m4_include(Lhc/Inst/Num.m4)+m4_include(Lhc/Order.m4)+m4_include(Foreign/Storable.m4)++INST_EQORDER(CInt,BitsInt_)+NUMINST(CInt, BitsInt_)+INST_STORABLE(CInt,BitsInt_,bits<int>)++INST_EQORDER(CSize,BitsSize_t_)+NUMINST(CSize, BitsSize_t_)+INST_STORABLE(CSize,BitsSize_t_,bits<size_t>)++INST_EQORDER(CWchar,Bits32_)+NUMINST(CWchar, Bits32_)+INST_STORABLE(CWchar,Bits32_,bits32)++INST_EQORDER(CChar,Bits8_)+NUMINST(CChar, Bits8_)+INST_STORABLE(CChar,Bits8_,bits8)++foreign import primitive "box" boxBool :: Bool__ -> Bool
lib/base/src/Lhc/Addr.hs view
@@ -80,4 +80,5 @@ castPtr :: Ptr a -> Ptr b castPtr (Ptr addr) = Ptr addr +foreign import primitive "box" boxBool :: Bool__ -> Bool
lib/base/src/Lhc/Basics.hs view
@@ -2,10 +2,12 @@ module Lhc.Basics(module Lhc.Basics, module Lhc.Prim) where import Lhc.Prim+import Lhc.Types import Lhc.Int data (->) :: ?? -> ? -> *-data Integer++data Integer = Integer BitsMax_ type String = [Char]
lib/base/src/Lhc/Enum.hs view
@@ -50,14 +50,51 @@ enumFromTo x y = f x where f x | x > y = [] | otherwise = x:f (increment x)- enumFromThenTo x y z | y >= x = f x where- inc = y `minus` x- f x | x <= z = x:f (x `plus` inc)- | otherwise = []- enumFromThenTo x y z = f x where- inc = y `minus` x- f x | x >= z = x:f (x `plus` inc)- | otherwise = []++ enumFromThenTo = efdtInt+++----------------------------------------------------------------------+-- Shamelessly stolen from GHC.Enum++efdtInt :: Int -> Int -> Int -> [Int]+-- [x1,x2..y]+efdtInt x1 x2 y+ | x2 >= x1 = efdtIntUp x1 x2 y+ | otherwise = efdtIntDn x1 x2 y++-- Requires x2 >= x1+efdtIntUp :: Int -> Int -> Int -> [Int]+efdtIntUp x1 x2 y -- Be careful about overflow!+ | y < x2 = if y < x1 then [] else [x1]+ | otherwise = -- Common case: x1 <= x2 <= y+ let delta = x2 `minus` x1 -- >= 0+ y' = y `minus` delta -- x1 <= y' <= y; hence y' is representable++ -- Invariant: x <= y+ -- Note that: z <= y' => z + delta won't overflow+ -- so we are guaranteed not to overflow if/when we recurse+ go_up x | x > y' = [x]+ | otherwise = x : go_up (x `plus` delta)+ in x1 : go_up x2++-- Requires x2 <= x1+efdtIntDn :: Int -> Int -> Int -> [Int]+efdtIntDn x1 x2 y -- Be careful about underflow!+ | y > x2 = if y > x1 then [] else [x1]+ | otherwise = -- Common case: x1 >= x2 >= y+ let delta = x2 `minus` x1 -- <= 0+ y' = y `minus` delta -- y <= y' <= x1; hence y' is representable++ -- Invariant: x >= y+ -- Note that: z >= y' => z + delta won't underflow+ -- so we are guaranteed not to underflow if/when w-e recurse+ go_dn x | x < y' = [x]+ | otherwise = x : go_dn (x `plus` delta)+ in x1 : go_dn x2++-- End shameless theft+---------------------------------------------------------------------- instance Enum Char where
lib/base/src/Lhc/IO.hs view
@@ -33,7 +33,6 @@ import Lhc.Prim import Lhc.Basics import Lhc.Order-import Foreign.C.Types import qualified Lhc.Options
lib/base/src/Lhc/Inst/Enum.hs view
@@ -7,9 +7,53 @@ import Lhc.Enum import Lhc.Num import Lhc.Order+import Lhc.Types import Lhc.IO(error) import Lhc.Basics +----------------------------------------------------------------------+-- Shamelessly stolen from GHC.Enum++efdt :: Integral i => i -> i -> i -> [i]+-- [x1,x2..y]+efdt x1 x2 y+ | x2 >= x1 = efdtUp x1 x2 y+ | otherwise = efdtDn x1 x2 y++-- Requires x2 >= x1+efdtUp :: Integral i => i -> i -> i -> [i]+efdtUp x1 x2 y -- Be careful about overflow!+ | y < x2 = if y < x1 then [] else [x1]+ | otherwise = -- Common case: x1 <= x2 <= y+ let delta = x2 - x1 -- >= 0+ y' = y - delta -- x1 <= y' <= y; hence y' is representable++ -- Invariant: x <= y+ -- Note that: z <= y' => z + delta won't overflow+ -- so we are guaranteed not to overflow if/when we recurse+ go_up x | x > y' = [x]+ | otherwise = x : go_up (x + delta)+ in x1 : go_up x2++-- Requires x2 <= x1+efdtDn :: Integral i => i -> i -> i -> [i]+efdtDn x1 x2 y -- Be careful about underflow!+ | y > x2 = if y > x1 then [] else [x1]+ | otherwise = -- Common case: x1 >= x2 >= y+ let delta = x2 - x1 -- <= 0+ y' = y - delta -- y <= y' <= x1; hence y' is representable++ -- Invariant: x >= y+ -- Note that: z >= y' => z + delta won't underflow+ -- so we are guaranteed not to underflow if/when w-e recurse+ go_dn x | x < y' = [x]+ | otherwise = x : go_dn (x + delta)+ in x1 : go_dn x2++-- End shameless theft+----------------------------------------------------------------------++ m4_define(ENUMINST,{{ instance Enum $1 where toEnum = fromInt@@ -23,14 +67,7 @@ enumFromTo x y = f x where f x | x > y = [] | otherwise = x:f (x + 1)- enumFromThenTo x y z | y >= x = inc `seq` z `seq` f x where- inc = y - x- f x | x <= z = x:f (x + inc)- | otherwise = []- enumFromThenTo x y z = dec `seq` z `seq` f x where- dec = x - y- f x | x >= z = x:f (x - dec)- | otherwise = []+ enumFromThenTo x1 x2 y = x1 `seq` x2 `seq` y `seq` efdt x1 x2 y foreign import primitive "increment" increment$1 :: $1 -> $1 foreign import primitive "decrement" decrement$1 :: $1 -> $1@@ -42,15 +79,13 @@ ENUMINST(Word16) ENUMINST(Word32) ENUMINST(Word64)-ENUMINST(WordPtr) ENUMINST(WordMax) ENUMINST(Int8) ENUMINST(Int16) ENUMINST(Int32) ENUMINST(Int64)-ENUMINST(IntPtr)-ENUMINST(IntMax)+{-ENUMINST(IntPtr)-} ENUMINST(Integer) @@ -67,4 +102,27 @@ enumFromTo () () = [()] enumFromThenTo () () () = let many = ():many in many +m4_define(INST_BOUNDED,{{+instance Bounded $1 where+ minBound = $1 (minBound$1 0#)+ maxBound = $1 (maxBound$1 0#) +foreign import primitive "minBound.$3" minBound$1 :: $2 -> $2+foreign import primitive "maxBound.$3" maxBound$1 :: $2 -> $2+}})++INST_BOUNDED(Int,Bits32_,bits32)+INST_BOUNDED(Int8,Bits8_,bits8)+INST_BOUNDED(Int16,Bits16_,bits16)+INST_BOUNDED(Int32,Bits32_,bits32)+INST_BOUNDED(Int64,Bits64_,bits64)++INST_BOUNDED(Word,Bits32_,bits32)+INST_BOUNDED(Word8,Bits8_,bits8)+INST_BOUNDED(Word16,Bits16_,bits16)+INST_BOUNDED(Word32,Bits32_,bits32)+INST_BOUNDED(Word64,Bits64_,bits64)+INST_BOUNDED(WordMax,BitsMax_,bits<max>)++-- Lemmih 2009.01.22: This instance shouldn't exist. Delete it.+INST_BOUNDED(Integer,BitsMax_,bits<max>)
+ lib/base/src/Lhc/Inst/Num.m4 view
@@ -0,0 +1,37 @@+m4_define(NUMINST,{{+instance Num $1 where+ $1 x + $1 y = $1 (add_$1 x y)+ $1 x - $1 y = $1 (sub_$1 x y)+ $1 x * $1 y = $1 (mul_$1 x y)+ + negate ($1 x) = $1 (neg_$1 x)+ + abs x | x < 0 = -x+ | otherwise = x+ + signum 0 = 0+ signum x | x < 0 = -1+ | otherwise = 1++ fromInteger (Integer x) = $1 (bitsmax_to_$1 x)+ fromInt (Int x) = $1 (bits32_to_$1 x)++instance Integral $1 where+ $1 n `quot` $1 d = $1 (div_$1 n d)+ $1 n `rem` $1 d = $1 (mod_$1 n d)++ toInteger ($1 x) = Integer (max_from_$1 x)+ toInt ($1 x) = Int (bits32_from_$1 x)++foreign import primitive "Neg" neg_$1 :: $2 -> $2+foreign import primitive "Add" add_$1 :: $2 -> $2 -> $2+foreign import primitive "Sub" sub_$1 :: $2 -> $2 -> $2+foreign import primitive "Mul" mul_$1 :: $2 -> $2 -> $2+foreign import primitive "$3Div" div_$1 :: $2 -> $2 -> $2+foreign import primitive "$3Mod" mod_$1 :: $2 -> $2 -> $2++foreign import primitive "I2I" bitsmax_to_$1 :: BitsMax_ -> $2+foreign import primitive "I2I" bits32_to_$1 :: Bits32_ -> $2+foreign import primitive "I2I" max_from_$1 :: $2 -> BitsMax_+foreign import primitive "I2I" bits32_from_$1 :: $2 -> Bits32_+}})
lib/base/src/Lhc/Inst/Read.hs view
@@ -26,7 +26,7 @@ READINST(Int16) READINST(Int32) READINST(Int64)-READINST(IntMax)+{-READINST(IntMax)-} READINST(IntPtr) m4_define(READWORD,{{
lib/base/src/Lhc/Inst/Show.hs view
@@ -7,6 +7,7 @@ import Lhc.Basics import Lhc.Num import Lhc.Order+import Lhc.Enum import Lhc.Show -- we convert them to Word or WordMax so the showIntAtBase specialization can occur.@@ -26,21 +27,25 @@ instance Show Word64 where showsPrec _ x = showWordMax (fromIntegral x :: WordMax) -instance Show WordPtr where- showsPrec _ x = showWordMax (fromIntegral x :: WordMax)+--instance Show WordPtr where+-- showsPrec _ x = showWordMax (fromIntegral x :: WordMax) instance Show WordMax where showsPrec _ x = showWordMax x ++-- SamB 2009.01.24: FIXME these could be more efficient if we re-did the branch structure like in GHC.Int, I think instance Show Int where showsPrec p x- | x < 0 = showParen (p > 6) (showChar '-' . showWord (fromIntegral $ negate x :: Word))+ | x == minBound = showParen (p > 6) (showChar '-' . showWord (fromIntegral x :: Word))+ | x < 0 = showParen (p > 6) (showChar '-' . showWord (fromIntegral $ negate x :: Word)) | otherwise = showWord (fromIntegral x :: Word) instance Show Integer where showsPrec p x- | x < 0 = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral $ negate x :: WordMax))- | otherwise = showWordMax (fromIntegral x :: WordMax)+ | x == minBound = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral x :: WordMax))+ | x < 0 = showParen (p > 6) (showChar '-' . showWordMax (fromIntegral $ negate x :: WordMax))+ | otherwise = showWordMax (fromIntegral x :: WordMax) instance Show Int8 where showsPrec p x = showsPrec p (fromIntegral x :: Int)
lib/base/src/Lhc/Inst/Storable.hs view
@@ -13,6 +13,9 @@ import Lhc.IO +INST_STORABLE(Int8,Bits8_,bits8)+INST_STORABLE(Int32,Bits32_,bits32)+INST_STORABLE(Word64,Bits64_,bits64) INST_STORABLE(Float,Float32_,fbits32) INST_STORABLE(Double,Float64_,fbits64)
lib/base/src/Lhc/List.hs view
@@ -178,7 +178,7 @@ last [] = error "Prelude.last: empty list" last (x:xs) = last' x xs where last' x [] = x- last' _ (y:ys) = last' y xs+ last' _ (y:ys) = last' y ys init :: [a] -> [a]
lib/base/src/Lhc/Num.hs view
@@ -1,6 +1,7 @@-{-# OPTIONS_LHC -N #-}+{-# OPTIONS_LHC -N -fffi -fm4 #-} module Lhc.Num where +import Lhc.Types import Lhc.Basics import Lhc.Order import Lhc.Show@@ -8,6 +9,7 @@ import Lhc.Enum import Lhc.Float + infixl 7 :% infixl 7 * , /, `quot`, `rem`, `div`, `mod` infixl 6 +, -@@ -105,4 +107,22 @@ even, odd :: (Integral a) => a -> Bool even n = n `rem` 2 == 0 odd = not . even++m4_include(Lhc/Inst/Num.m4)++NUMINST(Int,Bits32_)+NUMINST(Int8,Bits8_)+NUMINST(Int16,Bits16_)+NUMINST(Int32,Bits32_)+NUMINST(Int64,Bits64_)+NUMINST(IntPtr,BitsPtr_)+NUMINST(Integer,BitsMax_)++NUMINST(Word,Bits32_,U)+NUMINST(Word8,Bits8_,U)+NUMINST(WordMax,BitsMax_,U)+NUMINST(Word16,Bits16_,U)+NUMINST(Word32,Bits32_,U)+NUMINST(Word64,Bits64_,U)+NUMINST(WordPtr,BitsPtr_,U)
lib/base/src/Lhc/Order.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_LHC -N -fffi #-}+{-# OPTIONS_LHC -N -fffi -fm4 #-} module Lhc.Order( Bool(..),@@ -11,8 +11,10 @@ otherwise ) where +import Lhc.Types import Lhc.Enum import Lhc.Basics+import Lhc.Inst.Enum data Bool = False | True deriving (Eq, Ord, Bounded, Enum)@@ -92,10 +94,43 @@ x >= y = not (x < y) x <= y = not (y < x) +m4_include(Lhc/Order.m4) +INST_EQORDER(Word8,Bits8_,U)+INST_EQORDER(Word16,Bits16_,U)+INST_EQORDER(Word32,Bits32_,U)+INST_EQORDER(Word64,Bits64_,U)+INST_EQORDER(WordPtr,BitsPtr_,U)++INST_EQORDER(Int8,Bits8_)+INST_EQORDER(Int16,Bits16_)+INST_EQORDER(Int32,Bits32_)+INST_EQORDER(Int64,Bits64_)+INST_EQORDER(IntPtr,BitsPtr_)++instance Eq Int where+ Int x == Int y = boxBool (bits32Eq x y)+ Int x /= Int y = boxBool (bits32NEq x y)++instance Ord Int where+ Int x < Int y = boxBool (bits32Lt x y)+ Int x > Int y = boxBool (bits32Gt x y)+ Int x <= Int y = boxBool (bits32Lte x y)+ Int x >= Int y = boxBool (bits32Gte x y)++instance Eq Word where+ Word x == Word y = boxBool (bits32Eq x y)+ Word x /= Word y = boxBool (bits32NEq x y)++instance Ord Word where+ Word x < Word y = boxBool (bits32Lt x y)+ Word x > Word y = boxBool (bits32Gt x y)+ Word x <= Word y = boxBool (bits32Lte x y)+ Word x >= Word y = boxBool (bits32Gte x y)+ instance Eq Char where- Char x == Char y = boxBool (equalsChar x y)- Char x /= Char y = boxBool (nequalsChar x y)+ Char x == Char y = boxBool (bits32Eq x y)+ Char x /= Char y = boxBool (bits32NEq x y) instance Ord Char where Char x < Char y = boxBool (bits32ULt x y)@@ -103,6 +138,28 @@ Char x <= Char y = boxBool (bits32ULte x y) Char x >= Char y = boxBool (bits32UGte x y) ++instance Eq Integer where+ Integer x == Integer y = boxBool (bitsmaxEq x y)+ Integer x /= Integer y = boxBool (bitsmaxNEq x y)++instance Ord Integer where+ Integer x < Integer y = boxBool (bitsmaxLt x y)+ Integer x > Integer y = boxBool (bitsmaxGt x y)+ Integer x <= Integer y = boxBool (bitsmaxLte x y)+ Integer x >= Integer y = boxBool (bitsmaxGte x y)++instance Eq WordMax where+ WordMax x == WordMax y = boxBool (bitsmaxEq x y)+ WordMax x /= WordMax y = boxBool (bitsmaxNEq x y)++instance Ord WordMax where+ WordMax x < WordMax y = boxBool (bitsmaxLt x y)+ WordMax x > WordMax y = boxBool (bitsmaxGt x y)+ WordMax x <= WordMax y = boxBool (bitsmaxLte x y)+ WordMax x >= WordMax y = boxBool (bitsmaxGte x y)++ infixr 3 && infixr 2 || @@ -121,11 +178,24 @@ otherwise :: Bool otherwise = True -foreign import primitive "Eq" equalsChar :: Char__ -> Char__ -> Bool__-foreign import primitive "NEq" nequalsChar :: Char__ -> Char__ -> Bool__++foreign import primitive "Eq" bits32Eq :: Int__ -> Int__ -> Bool__+foreign import primitive "NEq" bits32NEq :: Int__ -> Int__ -> Bool__+foreign import primitive "Lt" bits32Lt :: Int__ -> Int__ -> Bool__+foreign import primitive "Lte" bits32Lte :: Int__ -> Int__ -> Bool__+foreign import primitive "Gt" bits32Gt :: Int__ -> Int__ -> Bool__+foreign import primitive "Gte" bits32Gte :: Int__ -> Int__ -> Bool__ foreign import primitive "ULt" bits32ULt :: Char__ -> Char__ -> Bool__ foreign import primitive "ULte" bits32ULte :: Char__ -> Char__ -> Bool__ foreign import primitive "UGt" bits32UGt :: Char__ -> Char__ -> Bool__ foreign import primitive "UGte" bits32UGte :: Char__ -> Char__ -> Bool__++foreign import primitive "Eq" bitsmaxEq :: BitsMax_ -> BitsMax_ -> Bool__+foreign import primitive "NEq" bitsmaxNEq :: BitsMax_ -> BitsMax_ -> Bool__+foreign import primitive "Lt" bitsmaxLt :: BitsMax_ -> BitsMax_ -> Bool__+foreign import primitive "Lte" bitsmaxLte :: BitsMax_ -> BitsMax_ -> Bool__+foreign import primitive "Gt" bitsmaxGt :: BitsMax_ -> BitsMax_ -> Bool__+foreign import primitive "Gte" bitsmaxGte :: BitsMax_ -> BitsMax_ -> Bool__+ foreign import primitive "box" boxBool :: Bool__ -> Bool
lib/base/src/Lhc/Order.m4 view
@@ -1,35 +1,29 @@ m4_divert(-1) m4_dnl simple macros for defining instances for classes in Lhc.Order -m4_define(BOXBOOL,{{ONCE({{-foreign import primitive "box" boxBool :: Bool__ -> Bool-}})}})- m4_define(INST_EQ,{{ instance Eq $1 where- $1 x == $1 y = boxBool (equals$2 x y)- $1 x /= $1 y = boxBool (nequals$2 x y)-ONCE({{-foreign import primitive "Eq" equals$2 :: $2 -> $2 -> Bool__-foreign import primitive "NEq" nequals$2 :: $2 -> $2 -> Bool__-}})-BOXBOOL()+ $1 x == $1 y = boxBool (equals$1 x y)+ $1 x /= $1 y = boxBool (nequals$1 x y)++foreign import primitive "Eq" equals$1 :: $2 -> $2 -> Bool__+foreign import primitive "NEq" nequals$1 :: $2 -> $2 -> Bool__+ }}) m4_define(INST_ORDER,{{ instance Ord $1 where- $1 x < $1 y = boxBool (lt$2 x y)- $1 x > $1 y = boxBool (gt$2 x y)- $1 x <= $1 y = boxBool (lte$2 x y)- $1 x >= $1 y = boxBool (gte$2 x y)-ONCE({{-foreign import primitive "$3Lt" lt$3$2 :: $2 -> $2 -> Bool__-foreign import primitive "$3Lte" lte$3$2 :: $2 -> $2 -> Bool__-foreign import primitive "$3Gt" gt$3$2 :: $2 -> $2 -> Bool__-foreign import primitive "$3Gte" gte$3$2 :: $2 -> $2 -> Bool__-}})-BOXBOOL()+ $1 x < $1 y = boxBool (lt$1 x y)+ $1 x > $1 y = boxBool (gt$1 x y)+ $1 x <= $1 y = boxBool (lte$1 x y)+ $1 x >= $1 y = boxBool (gte$1 x y)++foreign import primitive "$3Lt" lt$1 :: $2 -> $2 -> Bool__+foreign import primitive "$3Lte" lte$1 :: $2 -> $2 -> Bool__+foreign import primitive "$3Gt" gt$1 :: $2 -> $2 -> Bool__+foreign import primitive "$3Gte" gte$1 :: $2 -> $2 -> Bool__+ }}) m4_define(INST_EQORDER,{{INST_EQ($1,$2)INST_ORDER($1,$2,$3)}})
lib/base/src/Lhc/Prim.hs view
@@ -13,12 +13,26 @@ data World__ :: # -data Int+data Int = Int Bits32_+data Int8 = Int8 Bits8_+data Int16 = Int16 Bits16_+data Int32 = Int32 Bits32_+data Int64 = Int64 Bits64_+data IntPtr = IntPtr BitsPtr_++data Word = Word Word__+data WordMax = WordMax BitsMax_+data Word8 = Word8 Bits8_+data Word16 = Word16 Bits16_+data Word32 = Word32 Bits32_+data Word64 = Word64 Bits64_+data WordPtr = WordPtr BitsPtr_ data Char = Char Char__ type Bool__ = Bits16_ -- Change to Bits1_ when the time comes type Addr__ = BitsPtr_ type Int__ = Bits32_+type Word__ = Bits32_ type Char__ = Bits32_ type Enum__ = Bits16_
lib/base/src/Lhc/Types.hs view
@@ -10,6 +10,9 @@ data Bits128_ :: # data BitsPtr_ :: # data BitsMax_ :: #+data BitsShort_ :: #+data BitsInt_ :: #+data BitsSize_t_ :: # data Float32_ :: # data Float64_ :: #
lib/base/src/Prelude/Float.hs view
@@ -183,7 +183,7 @@ exp <- peek ptr return (x', fromIntegral exp) - encodeFloat i e = c_ldexp (integer2double i) (fromInt e)+ encodeFloat i e = c_ldexp (integer2double i) (fromInt e) decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do x' <- c_frexp x ptr exp <- peek ptr
lib/base/src/System.hs view
@@ -32,12 +32,12 @@ getProgName = case Lhc.Options.target of- Lhc.Options.GhcHs -> ghc_getProgName+-- Lhc.Options.GhcHs -> ghc_getProgName _ -> peek lhc_progname >>= peekCString getArgs = case Lhc.Options.target of- Lhc.Options.GhcHs -> ghc_getArgs- _ -> do+-- Lhc.Options.GhcHs -> ghc_getArgs+ _ -> do argc <- peek lhc_argc argv <- peek lhc_argv let f n = peekElemOff argv n >>= peekCString@@ -59,7 +59,7 @@ foreign import ccall "&lhc_progname" lhc_progname :: Ptr CString foreign import ccall "&lhc_argc" lhc_argc :: Ptr CInt foreign import ccall "&lhc_argv" lhc_argv :: Ptr (Ptr CString)-+{- ghc_getArgs :: IO [String] ghc_getArgs = alloca $ \ p_argc ->@@ -69,8 +69,8 @@ argv <- peek p_argv let f n = peekElemOff argv n >>= peekCString mapM f [1 .. fromIntegral p - 1]--+-}+{- foreign import unsafe ccall "getProgArgv" getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () @@ -81,4 +81,4 @@ getProgArgv p_argc p_argv argv <- peek p_argv peekElemOff argv 0 >>= peekCString-+-}
lib/base/src/System/IO.hs view
@@ -149,8 +149,10 @@ foreign import ccall "wchar.h lhc_utf8_putc" c_fputwc :: Int -> Ptr Handle -> IO Int foreign import ccall "stdio.h feof" c_feof :: Ptr Handle -> IO CInt-foreign import ccall "stdio.h ftell" c_ftell :: Ptr Handle -> IO IntMax -- XXX-foreign import ccall "stdio.h fseek" c_fseek :: Ptr Handle -> IntMax -> CInt -> IO CInt -- XXX+foreign import ccall "stdio.h ftell" c_ftell :: Ptr Handle -> IO Int -- XXX+--foreign import ccall "stdio.h ftell" c_ftell :: Ptr Handle -> IO IntMax -- XXX+foreign import ccall "stdio.h fseek" c_fseek :: Ptr Handle -> Int -> CInt -> IO CInt -- XXX+--foreign import ccall "stdio.h fseek" c_fseek :: Ptr Handle -> IntMax -> CInt -> IO CInt -- XXX foreign import primitive "const.SEEK_SET" c_SEEK_SET :: CInt foreign import primitive "const.SEEK_CUR" c_SEEK_CUR :: CInt
src/C/FromGrin2.hs view
@@ -74,8 +74,10 @@ runC :: Grin -> C a -> (a,HcHash,Written) runC grin (C m) = execUniq1 (runRWST m Env { rCPR = cpr, rGrin = grin, rDeclare = False, rTodo = TodoExp [], rEMap = mempty, rInscope = mempty } emptyHcHash) where TyEnv tmap = grinTypeEnv grin- cpr = iw `Set.union` Set.insert cChar (Set.fromList [ a | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) <- Map.assocs tmap, a == a', isJust (good s) ])- iw = if fopts FO.FullInt then Set.empty else Set.fromList [cInt, cWord]+ -- This controls the use of unboxed but tagged representations of types via VALUE and GETVALUE+ -- Int and Word used to be included when -ffull-int was not on, but we don't want that at this time+ cpr = Set.insert cChar (Set.fromList [ a | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) + <- Map.assocs tmap, a == a', isJust (good s) ]) good s = do ct <- Op.toCmmTy s b <- Op.cmmTyBits ct@@ -317,13 +319,15 @@ e' <- convertBody e return (ass & e') -}- am Var {} e = e- am ~(NodeC t2 _) e = annotate (show p2) (f_assert ((constant $ enum (nodeTagName t2)) `eq` tag) & e)+ am Var {} e = return e+ am ~(NodeC t2 _) e = do + tellTags t2+ return $ annotate (show p2) (f_assert ((constant $ enum (nodeTagName t2)) `eq` tag) & e) tag = f_GETWHAT scrut ifscrut = if null fps then f_RAWWHAT tenum `eq` scrut else tenum `eq` tag where tenum = (constant $ enum (nodeTagName t)) p1' <- da p1 e1- p2' <- liftM (am p2) $ da p2 e2+ p2' <- am p2 =<< da p2 e2 return $ profile_case_inc & cif ifscrut p1' p2' -- zero is usually faster to test for than other values, so flip them if zero is being tested for.
src/C/Generate.hs view
@@ -374,7 +374,7 @@ enum :: Name -> Constant enum n = C (draw n) -number :: Int -> Constant+number :: Integer -> Constant number i = C (tshow i) floating :: Double -> Constant
src/DataConstructors.hs view
@@ -65,7 +65,6 @@ import GenUtil import FrontEnd.HsSyn import Info.Types-import Support.MapBinaryInstance import Name.Id import Name.Name as Name import Name.Names@@ -86,7 +85,7 @@ tipe' (TArrow t1 t2) = do t1' <- tipe' t1 t2' <- tipe' t2- return $ EPi (tVr 0 (t1')) t2'+ return $ EPi (tVr emptyId (t1')) t2' tipe' (TCon (Tycon n k)) | Just n' <- lookup n primitiveAliases = return $ ELit litCons { litName = n', litType = kind k } tipe' (TCon (Tycon n k)) = return $ ELit litCons { litName = n, litType = kind k } tipe' (TVar tv@Tyvar { tyvarKind = k}) = do@@ -96,7 +95,7 @@ tipe' (TExists [] (_ :=> t)) = tipe' t tipe' (TForAll xs (_ :=> t)) = do xs' <- flip mapM xs $ \tv -> do- v <- newName [70,72..] () tv+ v <- newName (map anonymous [70,72..]) () tv return $ tVr v (kind $ tyvarKind tv) t' <- tipe' t return $ foldr EPi t' xs' -- [ tVr n (kind k) | n <- [2,4..] | k <- xs ]@@ -113,7 +112,7 @@ kind (KBase KUTuple) = eHash kind (KBase KHash) = eHash kind (KBase Star) = eStar-kind (Kfun k1 k2) = EPi (tVr 0 (kind k1)) (kind k2)+kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2) kind (KVar _) = error "Kind variable still existing." kind _ = error "DataConstructors.kind" @@ -173,8 +172,8 @@ } instance Binary DataTable where- put (DataTable dt) = putMap dt- get = fmap DataTable getMap+ put (DataTable dt) = put dt+ get = fmap DataTable get emptyConstructor = Constructor { conName = error "emptyConstructor.conName",@@ -231,10 +230,10 @@ dc = unboxedNameTuple DataConstructor n tc = unboxedNameTuple TypeConstructor n tipe = foldr ELam ftipe typeVars- typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- [ 2,4 ..]]- vars = [ tvr { tvrType = EVar t, tvrIdent = v } | v <- [ 2*n + 16, 2*n + 18 ..] | t <- typeVars ]+ typeVars = take n [ tvr { tvrType = eStar, tvrIdent = anonymous v } | v <- [ 2,4 ..]]+ vars = [ tvr { tvrType = EVar t, tvrIdent = anonymous v } | v <- [ 2*n + 16, 2*n + 18 ..] | t <- typeVars ] ftipe = ELit (litCons { litName = tc, litArgs = map EVar typeVars, litType = eHash })- dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = 0 } | v <- vars]) typeVars+ dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = emptyId } | v <- vars]) typeVars -- | conjured data types, these data types are created as needed and can be of any type, their@@ -259,9 +258,9 @@ tarrow = emptyConstructor { conName = tc_Arrow,- conType = EPi (tVr 0 eStar) (EPi (tVr 0 eStar) eStar),+ conType = EPi (tVr emptyId eStar) (EPi (tVr emptyId eStar) eStar), conOrigSlots = [SlotNormal eStar,SlotNormal eStar],- conExpr = ELam (tVr 2 eStar) (ELam (tVr 4 eStar) (EPi (tVr 0 (EVar $ tVr 2 eStar)) (EVar $ tVr 4 eStar))),+ conExpr = ELam (tVr (anonymous 2) eStar) (ELam (tVr (anonymous 4) eStar) (EPi (tVr emptyId (EVar $ tVr (anonymous 2) eStar)) (EVar $ tVr (anonymous 4) eStar))), conInhabits = tStar, conChildren = DataAbstract }@@ -281,7 +280,7 @@ conName = dc, conType = tipe, conOrigSlots = [SlotNormal rt],- conExpr = ELam (tVr 2 rt) (ELit (litCons { litName = dc, litArgs = [EVar (tVr 2 rt)], litType = tipe })),+ conExpr = ELam (tVr (anonymous 2) rt) (ELit (litCons { litName = dc, litArgs = [EVar (tVr (anonymous 2) rt)], litType = tipe })), conInhabits = tc } typeCons = emptyConstructor {@@ -297,9 +296,9 @@ -typesCompatable :: forall m . Monad m => DataTable -> E -> E -> m ()-typesCompatable dataTable a b = f (-2 :: Id) a b where- f :: Id -> E -> E -> m ()+typesCompatable :: forall m . Monad m => E -> E -> m ()+typesCompatable a b = f etherialIds a b where+ f :: [Id] -> E -> E -> m () f _ (ESort a) (ESort b) = when (a /= b) $ fail $ "Sorts don't match: " ++ pprint (ESort a,ESort b) f _ (EVar a) (EVar b) = when (a /= b) $ fail $ "Vars don't match: " ++ pprint (a,b) -- we expand aliases first, because the newtype might have phantom types as arguments@@ -316,19 +315,21 @@ f c b b' f c (ELam va ea) (ELam vb eb) = lam va ea vb eb c f c (EPi va ea) (EPi vb eb) = lam va ea vb eb c- f c (EPi (TVr { tvrIdent = 0, tvrType = a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) | conName tarrow == n, t == eStar = do+ f c (EPi (TVr { tvrIdent = i, tvrType = a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t }))+ | isEmptyId i, conName tarrow == n, t == eStar = do f c a a' f c b b'- f c (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) (EPi (TVr { tvrIdent = 0, tvrType = a}) b) | conName tarrow == n, t == eStar = do+ f c (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) (EPi (TVr { tvrIdent = i, tvrType = a}) b)+ | isEmptyId i, conName tarrow == n, t == eStar = do f c a a' f c b b' f _ a b | boxCompat a b || boxCompat b a = return () f _ a b = fail $ "Types don't match:" ++ pprint (a,b) - lam :: TVr -> E -> TVr -> E -> Id -> m ()- lam va ea vb eb c = do- f c (tvrType va) (tvrType vb)- f (c - 2) (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb)+ lam :: TVr -> E -> TVr -> E -> [Id] -> m ()+ lam va ea vb eb (c:cs) = do+ f (c:cs) (tvrType va) (tvrType vb)+ f cs (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) boxCompat (ELit (LitCons { litName = n })) t | Just e <- fromConjured modBox n = e == getType t boxCompat _ _ = False @@ -469,12 +470,12 @@ [it@(ELit LitCons { litName = it_name })] = conSlots conr Just itr = getConstructor it_name (DataTable mp) DataEnum mv = conChildren itr- v1 = tvr { tvrIdent = 2, tvrType = typ }- v2 = tvr { tvrIdent = 4, tvrType = typ }- i1 = tvr { tvrIdent = 6, tvrType = it }- i2 = tvr { tvrIdent = 8, tvrType = it }- b3 = tvr { tvrIdent = 10, tvrType = tBoolzh }- val1 = tvr { tvrIdent = 14, tvrType = typ }+ v1 = tvr { tvrIdent = anonymous 2, tvrType = typ }+ v2 = tvr { tvrIdent = anonymous 4, tvrType = typ }+ i1 = tvr { tvrIdent = anonymous 6, tvrType = it }+ i2 = tvr { tvrIdent = anonymous 8, tvrType = it }+ b3 = tvr { tvrIdent = anonymous 10, tvrType = tBoolzh }+ val1 = tvr { tvrIdent = anonymous 14, tvrType = typ } unbox e = ELam v1 (ELam v2 (ec (EVar v1) i1 (ec (EVar v2) i2 e))) where ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown h cl | cl == class_Eq = [mkCmpFunc (func_equals sFuncNames) Op.Eq]@@ -529,7 +530,7 @@ af = do Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable Constructor { conAlias = ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable- return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- [2,4..]])+ return (foldr ELam sl [ tVr (anonymous i) s | s <- getSlots cs | i <- [2,4..]]) removeNewtypes :: DataTable -> E -> E removeNewtypes dataTable e = runIdentity (f e) where@@ -568,7 +569,12 @@ consName = mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType)) rtypeName = mapName (id,(++ "#")) $ toName TypeConstructor (nameName (conName theType)) rtype = ELit litCons { litName = rtypeName, litType = eHash, litAliasFor = Just tEnumzh }- dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr 12 rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr 12 rtype)], litType = conExpr theType })) }+ dataCons = fc { conName = consName+ , conType = getType (conExpr dataCons)+ , conOrigSlots = [SlotNormal rtype]+ , conExpr = ELam (tVr (anonymous 12) rtype) (ELit (litCons { litName = consName+ , litArgs = [EVar (tVr (anonymous 12) rtype)]+ , litType = conExpr theType })) } rtypeCons = emptyConstructor { conName = rtypeName, conType = eHash,@@ -601,7 +607,7 @@ theExpr = foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars - strictize tslots con = E.Subst.subst tvr { tvrIdent = -1 } Unknown $ f tslots con where+ strictize tslots con = E.Subst.subst tvr { tvrIdent = sillyId } Unknown $ f tslots con where f (Left (v,False):rs) con = f rs con f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con) f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where@@ -611,9 +617,9 @@ -- substitution is only about substituting type variables (ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); ~(Just ty) -> ([],ty)- mapM_ (newName [2,4..] ()) vs+ mapM_ (newName (map anonymous [2,4..]) ()) vs tipe' ty- subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- [2,4..] ]+ subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = anonymous p }) | EVar tv <- thisTypeArgs | p <- [2,4..] ] origSlots = map SlotExistential existentials ++ map f tslots where f (Left (e,_)) = SlotNormal (getType e)@@ -634,7 +640,7 @@ return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es f _ [] [] = [] f _ _ _ = error "DataConstructors.tslots"- fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList [2,4 .. 2 * (length theTypeArgs + 2)]+ fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (map anonymous [2,4 .. 2 * (length theTypeArgs + 2)]) -- existentials are free variables in the arguments, that arn't bound in the type existentials = melems $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr)@@ -648,7 +654,7 @@ theTypeName = toName Name.TypeConstructor (hsDeclName decl) theKind = kind $ fromJust (Map.lookup theTypeName km) (theTypeFKind,theTypeKArgs') = fromPi theKind- theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- [2,4..] ]+ theTypeArgs = [ tvr { tvrIdent = anonymous x } | tvr <- theTypeKArgs' | x <- [2,4..] ] theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind } theType = emptyConstructor { conName = theTypeName,@@ -683,7 +689,7 @@ (vid:_) = newIds (freeVars typ) Just mc = getConstructor n dataTable Just pc = getConstructor (conInhabits mc) dataTable- sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- [2,4..] ]+ sub = substMap $ fromDistinctAscList [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ] constructionExpression wdt n e | Just fa <- followAlias wdt e = constructionExpression wdt n fa constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e @@ -706,7 +712,7 @@ f (v:vs) (SlotUnpacked e n es:ss) rs ls = do let g t = do s <- newUniq- return $ tVr (2*s) t+ return $ tVr (anonymous $ 2*s) t as <- mapM g es f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = e }):ls) f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e)@@ -725,7 +731,7 @@ where Identity mc = getConstructor n wdt Identity pc = getConstructor (conInhabits mc) wdt- sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- [2,4..] ]+ sub = substMap $ fromDistinctAscList [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ] slotTypes wdt n kind | sortKindLike kind, (e,ts) <- fromPi kind = drop (length ts) (conSlots mc) where Identity mc = getConstructor n wdt@@ -742,7 +748,7 @@ where Identity mc = getConstructor n wdt Identity pc = getConstructor (conInhabits mc) wdt- sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- [2,4..] ]+ sub = substMap $ fromDistinctAscList [ (anonymous i,sl) | sl <- xs | i <- [2,4..] ] slotTypesHs wdt n kind | sortKindLike kind, (e,ts) <- fromPi kind = drop (length ts) (conSlots mc) where Identity mc = getConstructor n wdt@@ -810,7 +816,7 @@ pprintTypeAsHs e = unparse $ runVarName (f e) where f e | e == eStar = return $ atom $ text "*" | e == eHash = return $ atom $ text "#"- f (EPi (TVr { tvrIdent = 0, tvrType = t1 }) t2) = do+ f (EPi (TVr { tvrIdent = n, tvrType = t1 }) t2) | isEmptyId n = do t1 <- f t1 t2 <- f t2 return $ t1 `arr` t2@@ -848,6 +854,9 @@ (tc_Bits128, rt_bits128), (tc_BitsPtr, rt_bits_ptr_), (tc_BitsMax, rt_bits_max_),+ (tc_BitsShort, rt_bits_short_),+ (tc_BitsInt, rt_bits_int_),+ (tc_BitsSize, rt_bits_size_t_), (tc_Float32, rt_float32), (tc_Float64, rt_float64),
src/DataConstructors.hs-boot view
@@ -7,7 +7,7 @@ data DataTable followAliases :: DataTable -> E -> E followAlias :: Monad m => DataTable -> E -> m E-typesCompatable :: Monad m => DataTable -> E -> E -> m ()+typesCompatable :: Monad m => E -> E -> m () updateLit :: DataTable -> Lit e t -> Lit e t slotTypes :: DataTable -> Name -> E -> [E] mktBox :: E -> E
src/Doc/DocLike.hs view
@@ -44,7 +44,7 @@ vcat xs = foldr1 (\x y -> x <> char '\n' <> y) xs x <+> y = x <> char ' ' <> y x <$> y = x <> char '\n' <> y- encloseSep l r s ds = enclose l r (hcat $ punctuate s ds)+ encloseSep l r s = enclose l r . hcat . punctuate s enclose l r x = l <> x <> r list = encloseSep lbracket rbracket comma tupled = encloseSep lparen rparen comma@@ -56,7 +56,7 @@ ------------------------ tshow :: (Show a,DocLike b) => a -> b-tshow x = text (show x)+tshow = text . show
src/E/Annotate.hs view
@@ -129,12 +129,12 @@ alts <- local r (mapM da $ eCaseAlts ec) t' <- f (eCaseType ec) return $ caseUpdate ECase { eCaseAllFV = error "no eCaseAllFV needed", eCaseScrutinee = e', eCaseType = t', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts }- lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == 0 = do+ lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | isEmptyId n = do t' <- f t nfo <- lift $ lamann e (tvrInfo tvr) nfo <- lift $ idann n nfo e' <- local (minsert n Nothing) $ f e- return $ lam (tvr { tvrIdent = 0, tvrType = t', tvrInfo = nfo}) e'+ return $ lam (tvr { tvrIdent = emptyId, tvrType = t', tvrInfo = nfo}) e' lp lam tvr e = do nfo <- lift $ lamann e (tvrInfo tvr) (tv,r) <- ntvr [] tvr { tvrInfo = nfo }@@ -146,9 +146,9 @@ (t',r) <- ntvr vs t local r $ f ts ((t',r):rs) vs = [ tvrIdent x | x <- ts ]- ntvr xs tvr@(TVr { tvrIdent = 0, tvrType = t}) = do+ ntvr xs tvr@(TVr { tvrIdent = i, tvrType = t}) | isEmptyId i = do t' <- f t- nfo <- lift $ idann 0 (tvrInfo tvr)+ nfo <- lift $ idann emptyId (tvrInfo tvr) let nvr = (tvr { tvrType = t', tvrInfo = nfo}) return (nvr,id) ntvr xs tvr@(TVr {tvrIdent = i, tvrType = t}) = do
src/E/Binary.hs view
@@ -4,34 +4,21 @@ import Data.Binary import E.Type import Monad-import Name.Binary() import {-# SOURCE #-} Info.Binary(putInfo,getInfo) - -- Binary instance-data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Word32+data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int instance Binary TVr where- put (TVr { tvrIdent = 0, tvrType = e, tvrInfo = nf} ) = do- put (TvrBinaryNone)- put e- putInfo nf- put (TVr { tvrIdent = i, tvrType = e, tvrInfo = nf}) | Just x <- intToAtom i = do- put (TvrBinaryAtom x)- put e- putInfo nf- put (TVr { tvrIdent = i, tvrType = e, tvrInfo = nf}) = do- put (TvrBinaryInt $ fromIntegral i)+ put (TVr { tvrIdent = i, tvrType = e, tvrInfo = nf} ) = do+ put i put e putInfo nf get = do- (x ) <- get+ i <- get e <- get nf <- getInfo- case x of- TvrBinaryNone -> return $ TVr 0 e nf- TvrBinaryAtom a -> return $ TVr (fromAtom a) e nf- TvrBinaryInt i -> return $ TVr (fromIntegral i) e nf+ return $ TVr i e nf instance Binary TvrBinary where put TvrBinaryNone = do putWord8 0
src/E/Demand.hs view
@@ -227,9 +227,6 @@ getEnv :: IM Env getEnv = asks fst -isEmptyId 0 = True-isEmptyId _ = False- extEnv TVr { tvrIdent = i } _ | isEmptyId i = id extEnv t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Left e) env,dt)) @@ -305,7 +302,7 @@ (t2',dt2) <- analyze t2 lazy return (EPi tvr { tvrType = t1' } t2',dt1 `glb` dt2) -analyze (ELam x@TVr { tvrIdent = 0 } e) (S (Product [s])) = do+analyze (ELam x@TVr { tvrIdent = i } e) (S (Product [s])) | isEmptyId i= do (e',phi :=> sigma) <- analyze e s let sx = Absent return (ELam (tvrInfo_u (Info.insert sx) x) e',demandEnvMinus phi x :=> (sx:sigma))
src/E/E.hs view
@@ -65,13 +65,13 @@ -tFunc a b = ePi (tVr 0 a) b+tFunc a b = ePi (tVr emptyId a) b -- values -tvrSilly = tVr ((-1)) Unknown+tvrSilly = tVr sillyId Unknown ----------------- -- E constructors
src/E/Eta.hs view
@@ -174,7 +174,7 @@ (ne,flag) <- f (min - 1) a e (subst tvr' (EVar tvr) rt) _ns return (ELam tvr ne,flag) f min (AFun _ a) e (EPi tt rt) _nns = do- if tvrIdent t == 0+ if isEmptyId (tvrIdent t) then Stats.mtick ("EtaExpand." ++ zeroName) else Stats.mtick ("EtaExpand.def.{" ++ tvrShowName t) n <- newName@@ -183,7 +183,7 @@ (ne,_) <- f (min - 1) a eb (subst tt (EVar nv) rt) _nns return (ELam nv ne,True) f min a e (EPi tt rt) _nns | min > 0 = do- if tvrIdent t == 0+ if isEmptyId (tvrIdent t) then Stats.mtick ("EtaExpand.min." ++ zeroName) else Stats.mtick ("EtaExpand.min.def.{" ++ tvrShowName t) n <- newName@@ -199,7 +199,7 @@ -- | eta expand a use of a value etaExpandAp :: (NameMonad Id m,Stats.MonadStats m) => DataTable -> TVr -> [E] -> m (Maybe E) etaExpandAp dataTable tvr xs = do- r <- etaExpandDef dataTable 0 tvr { tvrIdent = 0} (foldl EAp (EVar tvr) xs)+ r <- etaExpandDef dataTable 0 tvr { tvrIdent = emptyId} (foldl EAp (EVar tvr) xs) return (fmap snd r) {-
src/E/Eval.hs view
@@ -6,13 +6,14 @@ import Control.Monad.Writer import qualified Data.Map as Map +import Doc.DocLike import Doc.PPrint import E.E import E.FreeVars import {-# SOURCE #-} E.Show import E.Subst--+import Name.Id (isEmptyId)+import Name.Names (tc_Arrow) eval :: E -> E eval term = eval' term [] where@@ -22,6 +23,7 @@ eval' (EPi v body) [] = check_eta $ EPi v (eval body) eval' e@Unknown [] = e eval' e@ESort {} [] = e+ eval' (ELit LitCons { litName = n, litArgs = [a, b] }) [] | n == tc_Arrow = tFunc (eval a) (eval b) eval' (ELit lc@LitCons { litArgs = es }) [] = ELit lc { litArgs = map eval es } eval' e@ELit {} [] = e @@ -76,6 +78,10 @@ check_eta $ EPi v' body' eval' ds e@Unknown [] = return e eval' ds e@ESort {} [] = return e+ eval' ds (ELit LitCons { litName = n, litArgs = [a,b] }) [] | n == tc_Arrow = do+ a' <- eval' ds a []+ b' <- eval' ds b []+ return (tFunc a' b') eval' ds (ELit lc@LitCons { litArgs = es, litType = t }) [] = do es' <- mapM (\e -> eval' ds e []) es t' <- (eval' ds t [])@@ -86,7 +92,7 @@ eval' ds (ELam v body) (t:rest) = eval' ds (subst v t body) rest eval' ds (EPi v body) (t:rest) = eval' ds (subst v t body) rest -- fudge eval' ds (EAp t1 t2) stack = eval' ds t1 (t2:stack)- eval' _ds (EVar TVr { tvrIdent = 0 }) _stack = fail "empty ident in term"+ eval' _ds (EVar TVr { tvrIdent = i }) _stack | isEmptyId i = fail "empty ident in term" eval' ds t@(EVar v) stack | Just x <- Map.lookup v ds = eval' ds x stack | otherwise = do@@ -99,7 +105,12 @@ return (EError s nt) eval' ds e@EError {} [] = do return e - eval' ds e stack= fail $ "Cannot strong: \n" ++ render (pprint (e,stack))+ eval' ds e stack= fail . render $ text "Cannot strong:"+ <$> pprint e+ <$> text "With stack:"+ <$> pprint stack+ <$> text "And bindings for:"+ <$> pprint (Map.keys ds) unwind ds t [] = return t unwind ds t (t1:rest) = do
src/E/FreeVars.hs view
@@ -24,7 +24,7 @@ instance FreeVars E [TVr] where freeVars x = melems $ (freeVars x :: IdMap TVr)-instance FreeVars E [Int] where+instance FreeVars E [Id] where freeVars e = idSetToList (freeVars e) instance FreeVars E t => FreeVars TVr t where
src/E/FromHs.hs view
@@ -46,6 +46,7 @@ import Info.Types import Name.Name as Name import Name.Names+import Name.Id import Name.VConsts import Options import PackedString@@ -74,17 +75,17 @@ ifzh e a b = eCase e [Alt lTruezh a, Alt lFalsezh b] Unknown -newVars :: UniqueProducer m => [E] -> m [TVr]+newVars :: Monad m => [E] -> Ce m [TVr] newVars xs = f xs [] where f [] xs = return $ reverse xs f (x:xs) ys = do s <- newUniq- f xs (tVr (2*s) x:ys)+ f xs (tVr (anonymous (2*s)) x:ys) tipe t = f t where f (TAp t1 t2) = eAp (f t1) (f t2)- f (TArrow t1 t2) = EPi (tVr 0 (f t1)) (f t2)+ f (TArrow t1 t2) = EPi (tVr emptyId (f t1)) (f t2) f (TCon (Tycon n k)) | Just n' <- lookup n primitiveAliases = ELit litCons { litName = n', litType = kind k } f (TCon (Tycon n k)) = ELit litCons { litName = n, litType = kind k } f (TVar tv) = EVar (cvar [] tv)@@ -105,7 +106,7 @@ kind (KBase Star) = eStar kind (KBase KQuest) = eStar -- XXX why do these still exist? kind (KBase KQuestQuest) = eStar-kind (Kfun k1 k2) = EPi (tVr 0 (kind k1)) (kind k2)+kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2) kind (KVar _) = error "Kind variable still existing." kind _ = error "E.FromHs.kind: unknown" @@ -179,7 +180,7 @@ Nothing | fopts FO.Raw -> EAp (EAp runRaw ty) maine Nothing -> EAp (EAp runExpr ty) maine ne = ELam worldVar (EAp e (EVar worldVar))- worldVar = tvr { tvrIdent = 2, tvrType = tWorld__ }+ worldVar = tvr { tvrIdent = anonymous 2, tvrType = tWorld__ } theMainTvr = tVr (toId cname) (infertype dataTable ne) tvm@(TVr { tvrType = ty}) = main maine = foldl EAp (EVar tvm) [ tAbsurd k | TVr { tvrType = k } <- xs, sortKindLike k ]@@ -197,12 +198,12 @@ _methodName@(~(Just (TVr {tvrType = ty},_))) = findName methodName defaultName = (defaultInstanceName methodName) valToPat' (ELit LitCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }) = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts') where- ts' = [ EVar (tVr j (getType z)) | z <- ts | j <- [2,4 ..], j `notElem` map tvrIdent args]+ ts' = [ EVar (tVr (anonymous j) (getType z)) | z <- ts | j <- [2,4 ..], anonymous j `notElem` map tvrIdent args] --valToPat' (EPi (TVr { tvrType = a}) b) = ELit $ litCons { litName = tc_Arrow, litArgs = [ EVar (tVr j (getType z)) | z <- [a,b] | j <- [2,4 ..], j `notElem` map tvrIdent args], litType = eStar } valToPat' (EPi tv@TVr { tvrType = a} b) = (EPi tvr { tvrType = a'} b',[a',b']) where a' = EVar (tVr ja (getType a)) b' = EVar (tVr jb (getType b))- (ja:jb:_) = [ j | j <- [2,4 ..], j `notElem` map tvrIdent args]+ (ja:jb:_) = [ anonymous j | j <- [2,4 ..], anonymous j `notElem` map tvrIdent args] valToPat' x = error $ "FromHs.valToPat': " ++ show x as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (classInsts classRecord) ] (_ft,_:args') = fromPi ty@@ -238,14 +239,14 @@ -unbox :: DataTable -> E -> Int -> (E -> E) -> E+unbox :: DataTable -> E -> Id -> (E -> E) -> E unbox dataTable e _vn wtd | getType (getType e) == eHash = wtd e unbox dataTable e vn wtd = eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd (EVar tvra))] Unknown where te = getType e tvra = tVr vn sta Just (cna,sta,ta) = lookupCType' dataTable te -createFunc :: UniqueProducer m => DataTable -> [E] -> ([(TVr,String)] -> (E -> E,E)) -> m E+createFunc :: Monad m => DataTable -> [E] -> ([(TVr,String)] -> (E -> E,E)) -> Ce m E createFunc dataTable es ee = do xs <- flip mapM es $ \te -> do res@(_,sta,rt) <- lookupCType' dataTable te@@ -267,7 +268,13 @@ convertRules mod tiData classHierarchy assumps dataTable hsDecls = ans where ans = do rawRules <- concatMapM g hsDecls- return $ fromRules [ makeRule n (mod,i) (if catalyst then RuleCatalyst else RuleUser) vs head args e2 | (catalyst,n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 | i <- [1..] ]+ return $ fromRules [ makeRule n (mod,i) ruleType vs head args e2+ | (catalyst,method,n,vs,e1,e2) <- rawRules,+ let (EVar head,args) = fromAp e1,+ let ruleType | catalyst = RuleCatalyst+ | method = RuleSpecialization+ | otherwise = RuleUser+ | i <- [1..] ] g (HsPragmaRules rs) = mapM f rs g _ = return [] f pr = do@@ -290,7 +297,7 @@ e2' = deNewtype dataTable $ smt $ sma e2 --e2 <- atomizeAp False dataTable Stats.theStats mainModule e2' let e2 = atomizeAp mempty False dataTable e2'- return (hsRuleIsMeta pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)+ return (hsRuleIsMeta pr,hsRuleIsMethod pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2) convertE :: Monad m => TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> SrcLoc -> HsExp -> m E convertE tiData classHierarchy assumps dataTable srcLoc exp = do@@ -368,7 +375,7 @@ | "Instance@" `isPrefixOf` show a = (a,setProperty prop_INSTANCE b, deNewtype dataTable c) | otherwise = (a,b, deNewtype dataTable c) - marshallToC :: UniqueProducer m => DataTable -> E -> E -> m E+ marshallToC :: Monad m => DataTable -> E -> E -> Ce m E marshallToC dataTable e te | otherwise = do (cna,sta,ta) <- lookupCType' dataTable te [tvra] <- newVars [sta]@@ -377,7 +384,7 @@ (EVar tvra)] Unknown - marshallFromC :: UniqueProducer m => DataTable -> E -> E -> m E+ marshallFromC :: Monad m => DataTable -> E -> E -> Ce m E marshallFromC dataTable ce te | otherwise = do (cna,sta,ta) <- lookupCType' dataTable te return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })@@ -716,7 +723,7 @@ Just p | getProperty prop_NOETA p -> span (sortKindLike . getType) as _ -> (as,[]) ft = foldr EPi ft' rargs- return (cClass cr ++ primitiveInstances className)+ return (cClass cr) -- ++ primitiveInstances className) cClassDecl _ = error "cClassDecl" convertVar n = do
src/E/LambdaLift.hs view
@@ -64,7 +64,7 @@ (body,args) = fromLam v (droppedAs,keptAs) = splitAt dropArgs args rbody = foldr ELam (subst t newV body) keptAs- newV = foldr ELam (EVar tvr') [ t { tvrIdent = 0 } | t <- droppedAs ]+ newV = foldr ELam (EVar tvr') [ t { tvrIdent = emptyId } | t <- droppedAs ] tvr' = tvr { tvrIdent = nname, tvrType = getType rbody } ne' = foldr ELam (ELetRec [(tvr',rbody)] (foldl EAp (EVar tvr') (map EVar keptAs))) args ans = do@@ -72,7 +72,7 @@ ne' <- g ne' return [(t,ne')] f _ (Right ts) = gds ts- gds ts = mapM g' ts >>= return where+ gds ts = mapM g' ts where g' (t,e) = g e >>= return . (,) t g elet@ELetRec { eDefs = ds } = do ds'' <- mapM (f False) (decomposeDs ds)@@ -282,7 +282,7 @@ t <- globalName t tellCombinator (t,ls,e'') r- globalName tvr | not $ isValidAtom (tvrIdent tvr) = do+ globalName tvr | not $ idIsNamed (tvrIdent tvr) = do TVr { tvrIdent = t } <- newName Unknown let ntvr = tvr { tvrIdent = t } tell ([],msingleton (tvrIdent tvr) (Just $ EVar ntvr))
src/E/LetFloat.hs view
@@ -55,10 +55,10 @@ f el@ELetRec { eDefs = ds } = local (`mappend` fromList (map (tvrIdent . fst) ds)) $ emapEG f return el f ec@ECase {} = local (`mappend` fromList (map tvrIdent (caseBinds ec))) $ emapEG f return ec f (ELit lc@LitCons { litArgs = xs }) = mapM f xs >>= dl (\xs -> ELit lc { litArgs = xs })- f ep@(EPi tvr@TVr {tvrIdent = i, tvrType = t} b) | i == 0 || i `notMember` freeIds b = do+ f ep@(EPi tvr@TVr {tvrIdent = i, tvrType = t} b) | isEmptyId i || i `notMember` freeIds b = do t <- f t b <- f b- dl (\ [t,b] -> EPi tvr { tvrIdent = 0, tvrType = t } b) [t,b]+ dl (\ [t,b] -> EPi tvr { tvrIdent = emptyId, tvrType = t } b) [t,b] f ep@(EPi TVr { tvrIdent = i } _) = local (insert i) $ emapEG f return ep f (EPrim n xs t) = mapM f xs >>= dl (\xs -> EPrim n xs t) f e = case fromAp e of
src/E/PrimOpt.hs view
@@ -41,7 +41,7 @@ -} -unbox :: DataTable -> E -> Int -> (TVr -> E) -> E+unbox :: DataTable -> E -> Id -> (TVr -> E) -> E unbox dataTable e vn wtd = eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd tvra)] Unknown where te = getType e tvra = tVr vn sta
src/E/Program.hs view
@@ -15,6 +15,7 @@ import Doc.Pretty import E.E import E.Show+import E.Rules () import E.TypeCheck import FrontEnd.Class import Util.Gen hiding(putErrLn)@@ -86,7 +87,7 @@ check x | not flint = x | hasRepeatUnder combIdent ds = error $ "programSetDs: program has redundant definitions: \n" ++ names- | any (not . isValidAtom) (map combIdent ds) = error $ "programSetDs: trying to set non unique top level name: \n" ++ names+ | any (not . idIsNamed) (map combIdent ds) = error $ "programSetDs: trying to set non unique top level name: \n" ++ names | otherwise = x names = intercalate "\n" (sort $ map (show . tvrShowName . combHead) ds) @@ -113,22 +114,31 @@ let f' (t,e) = f e >>= \e' -> return (t,e') programMapDs f' prog +programMapDs :: Monad m => ((TVr, E) -> m (TVr, E)) -> Program -> m Program programMapDs f prog = do cs <- forM (progCombinators prog) $ \comb -> do (t,e) <- f (combHead comb,combBody comb) return . combHead_s t . combBody_s e $ comb return $ progCombinators_s cs prog +programMapDs_ :: Monad m => ((TVr,E) -> m ()) -> Program -> m () programMapDs_ f prog = mapM_ f (programDs prog) hPrintProgram fh prog@Program {progCombinators = cs, progDataTable = dataTable } = do- sequence_ $ intersperse (hPutStrLn fh "") [ hPrintCheckName fh dataTable v e | Comb { combHead = v, combBody = e } <- cs]- when (progMain prog /= emptyId) $+ sequence_ $ intersperse (hPutStrLn fh "") $ map (hPrintComb fh dataTable) cs+ when (not (isEmptyId (progMain prog))) $ hPutStrLn fh $ "MainEntry: " ++ pprint (progMainEntry prog) when (progEntry prog /= singleton (progMain prog)) $ hPutStrLn fh $ "EntryPoints: " ++ hsep (map pprint (progEntryPoints prog)) printProgram prog = hPrintProgram IO.stderr prog+++hPrintComb :: IO.Handle -> DataTable -> Comb -> IO ()+hPrintComb fh dataTable (Comb { combHead = v, combBody = e, combRules = r }) = do+ do wdump FD.Rules $ hPutStrLn fh ("rules: "++show r)+ hPrintCheckName fh dataTable v e+ printCheckName'' = hPrintCheckName IO.stderr
src/E/Rules.hs view
@@ -28,12 +28,12 @@ import Doc.Pretty import E.Binary() import E.E-import E.Show()+import E.Show(render) import E.Subst import E.Values+import DataConstructors(typesCompatable) import GenUtil import Info.Types-import Support.MapBinaryInstance() import Name.Id import Name.Name import Name.Names@@ -104,11 +104,10 @@ let p v = parens $ pprint v <> text "::" <> pprint (getType v) putDocMLn' CharIO.putStr $ (tshow n) <+> text "forall" <+> hsep (map p vs) <+> text "." let ty = pprint $ getType e1 -- case inferType dataTable [] e1 of- -- ty2 = pprint $ getType e2+ ty2 = pprint $ getType e2 putDocMLn' CharIO.putStr (indent 2 (pprint e1) <+> text "::" <+> ty ) putDocMLn' CharIO.putStr $ text " ==>" <+> pprint e2- --putDocMLn CharIO.putStr (indent 2 (pprint e2))- --putDocMLn CharIO.putStr (indent 2 (text "::" <+> ty2))+ putDocMLn' CharIO.putStr (indent 2 (text "::" <+> ty2)) combineRules as bs = map head $ sortGroupUnder ruleUniq (as ++ bs) @@ -223,7 +222,19 @@ -> [E] -- ^ the args -> E -- ^ the body -> Rule-makeRule name uniq ruleType fvs head args body = rule where+makeRule name uniq ruleType fvs head args body+ | Left e <- typesCompatable lty rty =+ error $ render (text "E.Rules.makeRule: type error in rule" <+> text name+ <$> text e+ <$> text "in" <+> (align (pprint lhs)+ <$> text " :: " <> align (pprint lty))+ <$> text "==>" <+> (align (pprint body)+ <$> text " :: " <> align (pprint rty)))+ | otherwise = rule+ where+ lhs = (foldl eAp (EVar head) args)+ lty = getType lhs+ rty = getType body rule = emptyRule { ruleHead = head, ruleBinds = fvs,@@ -245,7 +256,7 @@ -> E -- ^ pattern to match -> E -- ^ input expression -> m [(TVr,E)]-match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () (-2::Int)) where+match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () etherialIds) where bvs :: IdSet bvs = fromList (map tvrIdent vs) @@ -265,14 +276,14 @@ un t t' mm c un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) mm c | i == j = un t u mm c- un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) mm c | i < 0 || j < 0 = fail "Expressions don't match"+ un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) mm c | isEtherialId i || isEtherialId j = fail "Expressions don't match" un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b mm c | i `member` bvs = tell (Seq.single (tvr,b)) | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b un a (EVar tvr) mm c | Just b <- lup (tvrIdent tvr), not $ isEVar b = un a b mm c un a b _ _ = fail $ "Expressions do not unify: " ++ show a ++ show b- lam va ea vb eb mm c = do- un (tvrType va) (tvrType vb) mm c- un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm (c - 2)+ lam va ea vb eb mm (c:cs) = do+ un (tvrType va) (tvrType vb) mm (c:cs)+ un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm cs
src/E/SSimplify.hs view
@@ -151,7 +151,7 @@ collectOccurance e = f e where f e@ESort {} = return e f e@Unknown {} = return e- f (EPi tvr@TVr { tvrIdent = 0, tvrType = a} b) = arg $ do+ f (EPi tvr@TVr { tvrIdent = n, tvrType = a} b) | isEmptyId n = arg $ do a <- f a b <- f b return (EPi tvr { tvrType = a } b)@@ -159,7 +159,7 @@ a <- f a (b,tfvs) <- grump (f b) case mlookup n tfvs of- Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = 0, tvrType = a } b)+ Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = emptyId, tvrType = a } b) Just occ -> tell (mdelete n tfvs,singleton n) >> return (EPi (annb' tvr { tvrType = a }) b) f (ELit lc@LitCons { litArgs = as, litType = t }) = arg $ do t <- f t@@ -269,12 +269,12 @@ -- delete any occurance info for non-let-bound vars to be safe annb' tvr = tvrInfo_u (Info.delete noUseInfo) tvr annbind' idm tvr = case mlookup (tvrIdent tvr) idm of- Nothing | sortTermLike (getType tvr) -> annb' tvr { tvrIdent = 0 }+ Nothing | sortTermLike (getType tvr) -> annb' tvr { tvrIdent = emptyId } _ -> annb' tvr -- add ocucrance info annbind idm tvr = case mlookup (tvrIdent tvr) idm of- Nothing -> annb notUsedInfo tvr { tvrIdent = 0 }+ Nothing -> annb notUsedInfo tvr { tvrIdent = emptyId } Just x -> annb x tvr annb x tvr = tvrInfo_u (Info.insert x) tvr @@ -387,23 +387,23 @@ insertSuspSubst t e env = insertSuspSubst' (tvrIdent t) e env insertSuspSubst' :: Id -> InE -> Env -> Env-insertSuspSubst' 0 _e env = env+insertSuspSubst' t _e env | isEmptyId t = env insertSuspSubst' t e env = cacheSubst env { envSubst = minsert t (susp e (envSubst env)) (envSubst env) } insertRange :: Id -> Range -> Env -> Env-insertRange 0 e env = env+insertRange t e env | isEmptyId t = env insertRange t e env = cacheSubst env { envSubst = minsert t e (envSubst env) } insertDoneSubst :: TVr -> OutE -> Env -> Env insertDoneSubst t e env = insertDoneSubst' (tvrIdent t) e env insertDoneSubst' :: Id -> OutE -> Env -> Env-insertDoneSubst' 0 _e env = env+insertDoneSubst' t _e env | isEmptyId t = env insertDoneSubst' t e env = insertRange t (Done e) env insertInScope :: Id -> Binding -> Env -> Env-insertInScope 0 _b env = env+insertInScope t _b env | isEmptyId t = env insertInScope t b env = extendScope (msingleton t b) env extendScope :: IdMap Binding -> Env -> Env@@ -569,8 +569,8 @@ done StartContext res f cont e = trace ("Fall through: " ++ show (cont,e)) $ dosub e >>= done cont - showName t | isValidAtom t || dump FD.EVerbose = tvrShowName (tVr t Unknown)- | otherwise = "(epheremal)"+ showName t | idIsNamed t || dump FD.EVerbose = tvrShowName (tVr t Unknown)+ | otherwise = "(epheremal)" -- Rename a if necessary. We always have to substitute all occurrences because we update the type. -- nname tvr = renameSM tvr@@ -578,7 +578,7 @@ t' <- dosub t inb <- ask let t'' = substMap' (envInScopeCache inb) t'- n' <- if n == 0 then return 0 else uniqueName n+ n' <- if isEmptyId n then return emptyId else uniqueName n return $ tvr { tvrIdent = n', tvrType = t'' } -- TODO - case simplification tickCont (ApplyTo _ cont) cs = mtick ("E.Simplify.application-push." ++ cs) >> tickCont cont cs@@ -687,7 +687,7 @@ doCase e _ b [] (Just d) | isUnboxed (getType e), isAtomic e = do mtick "E.Simplify.case-atomic-unboxed" localEnv (insertDoneSubst b e) $ f cont d- doCase e _ TVr { tvrIdent = 0 } [] (Just d) | isOmittable inb e = do+ doCase e _ TVr { tvrIdent = n } [] (Just d) | isEmptyId n, isOmittable inb e = do mtick "E.Simplify.case-omittable" f cont d doCase (EVar v) _ b [] (Just d) | Just (NotAmong _) <- varval = do@@ -703,7 +703,7 @@ tickCont cont "case" b' <- nname b (ids,b') <- case (e,tvrIdent b') of- (EVar v,0) -> do+ (EVar v,i) | isEmptyId i -> do nn <- newName b' <- return b' { tvrIdent = nn } return $ (insertInScope (tvrIdent v) (isBoundTo noUseInfo (EVar b')),b')@@ -726,7 +726,7 @@ ninb = fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- ns' ] e' <- localEnv (const $ ids $ substAddList nsub (extendScope ninb $ mins e (patToLitEE p') inb)) $ f cont ae return $ Alt p' e'- mins _ e | 0 `notMember` (freeVars e :: IdSet) = insertInScope (tvrIdent b') (isBoundTo noUseInfo e)+ mins _ e | emptyId `notMember` (freeVars e :: IdSet) = insertInScope (tvrIdent b') (isBoundTo noUseInfo e) mins _ _ = id d' <- T.mapM dd d@@ -759,7 +759,7 @@ inb <- ask case mr of Just (bs,e) -> do- let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= 0]+ let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, not (isEmptyId n)] binds <- mapM (\ (v,e) -> nname v >>= return . (,,) e v) bs' e' <- localEnv (substAddList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] . extendScope (fromList [ (n,isBoundTo noUseInfo e) | (e,_,TVr { tvrIdent = n }) <- binds])) $ f StartContext e done cont $ eLetRec [ (v,e) | (e,_,v) <- binds ] e'@@ -844,7 +844,9 @@ -- Nothing -> error $ "Var not in scope: " ++ show v hFunc e xs' = do app (e,xs') didInline ::OutE -> [OutE] -> SM OutE- didInline z zs = return (foldl EAp z zs)+ -- SamB 2009.01.14:+ -- FIXME does this always need to happen? Definately needs to happen sometimes. Without it,+ -- we were getting E type errors in fastest_fib. didInline z zs = do used <- smUsedNames let (ne,nn) = runRename used (foldl EAp z zs)@@ -918,7 +920,35 @@ ds' <- sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds'] return (ds',inb') +{-+simplExpr subst ins e = e +simplExprs subst ins ds+ = do +-}++-- Rename a variable if it shadowes anything from the current scope.+-- It is unfortunate that we have to stay in the SM monad for this.+renameSM :: TVr -> SM TVr+renameSM tvr = do env <- ask+ t' <- dosub (tvrType tvr)+ inb <- ask+ let t'' = substMap' (envInScopeCache inb) t'+ case mmember (tvrIdent tvr) (envInScope env) of+ False -> return tvr{ tvrType = t''}+ True -> do let ns = genNewId env+ return tvr{ tvrIdent = ns+ , tvrType = t''}++newNameSM :: (Id -> SM a) -> SM a+newNameSM fn+ = do env <- ask+ let ident = genNewId env+ localEnv (insertInScope ident NotKnown) (fn ident)++genNewId env = head $ filter (`mnotMember` envInScope env) $ idList+ where idList = map anonymous [2,4..]+ data KnowSomething = KnowNothing | KnowNotOneOf [Name] | KnowIsCon Name | KnowIsNum Number | KnowSomething deriving(Eq) @@ -1081,7 +1111,7 @@ sm <- get let (g1,g2) = split (smStdGen sm) put sm{smStdGen = g1}- newNameFrom (filter (>0) $ filter even $ randoms g2)+ newNameFrom (map anonymous $ filter (>0) $ filter even $ randoms g2) smUsedNames = SM $ gets idsUsed smBoundNames = SM $ gets idsBound
src/E/Show.hs view
@@ -37,7 +37,7 @@ ePrettyEx = ePretty showId :: DocLike d => Id -> d-showId 0 = (char '_')+showId i | isEmptyId i = (char '_') showId i | Just x <- fromId i = (text $ show x) showId i = (text $ 'x':show i) @@ -83,6 +83,11 @@ f LitCons { litName = s, litArgs = es } | Just n <- fromUnboxedNameTuple s, n == length es = do es' <- mapM (fmap unparse . showBind) es return $ atom $ encloseSep (text "(# ") (text " #)") (text ", ") es'+ -- Fully-applied tc_Arrows are not good, so make them red so that they are easy to spot+ f LitCons { litName = n, litArgs = [a,b] } | tc_Arrow == n = do+ a' <- showBind a+ b' <- showBind b+ return $ foldl appCon (atom $ col "red" $ tshow n) [a',b'] f LitCons { litName = n, litArgs = [a,b] } | dc_Cons == n = do a' <- showBind a b' <- showBind b@@ -133,12 +138,12 @@ allocTVr :: TVr -> SEM a -> SEM a allocTVr _tvr action | dump FD.EVerbose = action-allocTVr tvr action | tvrIdent tvr == 0 = action+allocTVr tvr action | isEmptyId (tvrIdent tvr) = action allocTVr tvr (SEM action) | tvrType tvr == eStar = do SEM $ subVarName $ newName (map (:[]) ['a' ..]) eStar (tvrIdent tvr) >> action allocTVr tvr (SEM action) | tvrType tvr == eStar `tFunc` eStar = do SEM $ subVarName $ newName (map (('f':) . show) [0::Int ..]) (tvrType tvr) (tvrIdent tvr) >> action-allocTVr tvr (SEM action) | not $ isValidAtom (tvrIdent tvr) = do+allocTVr tvr (SEM action) | not $ idIsNamed (tvrIdent tvr) = do SEM $ subVarName $ newName (map (('v':) . show) [1::Int ..]) Unknown (tvrIdent tvr) >> action allocTVr _ action = action @@ -146,7 +151,7 @@ -- collects lambda and pi abstractions collectAbstractions e0 = go e0 [] where- go e1@(EPi tvr e) xs | tvrIdent tvr == 0 = done e1 xs+ go e1@(EPi tvr e) xs | isEmptyId (tvrIdent tvr) = done e1 xs | not (sortKindLike (tvrType tvr)) = go e ((UC.pI, tvr, True) :xs) | tvrType tvr /= eStar = go e ((UC.forall, tvr, True) :xs) | dump FD.EVerbose || tvrIdent tvr `member` (freeVars e::IdSet)@@ -178,7 +183,7 @@ f e | e == vTrue = return $ atom $ text "True" f e | e == vUnit = return $ atom $ text "()" f (EAp a b) = liftM2 app (showE a) (showE b)- f (EPi (TVr { tvrIdent = 0, tvrType = e1}) e2) = liftM2 arr (showE e1) (showE e2)+ f (EPi (TVr { tvrIdent = n, tvrType = e1}) e2) | isEmptyId n = liftM2 arr (showE e1) (showE e2) f (EPi (TVr { tvrIdent = n, tvrType = e1}) e2) | not $ dump FD.EVerbose, not $ n `member` (freeVars e2 ::IdSet) = liftM2 arr (showE e1) (showE e2) f e0 | (as@(_:_), e) <- collectAbstractions e0 = foldr (\(_, tvr, _) -> allocTVr tvr)@@ -216,7 +221,7 @@ alts <- mapM showAlt alts let ecb = eCaseBind ec isUsed = tvrIdent ecb `member` (freeVars (caseBodies ec) :: IdSet)- db <- showTVr (if dump FD.EVerbose || isUsed then ecb else ecb { tvrIdent = 0 })+ db <- showTVr (if dump FD.EVerbose || isUsed then ecb else ecb { tvrIdent = emptyId }) dcase <- case (eCaseDefault ec) of Nothing -> return [] Just e -> do
src/E/Subst.hs view
@@ -52,7 +52,7 @@ import qualified Data.Set as Set eLetRec :: [(TVr,E)] -> E -> E-eLetRec ds e = f (filter ((/= 0) . tvrIdent . fst) ds) where+eLetRec ds e = f (filter ((not . isEmptyId) . tvrIdent . fst) ds) where f [] = e f ds = ELetRec ds e @@ -63,7 +63,7 @@ -> E -- ^ What to substitute with -> E -- ^ input term -> E -- ^ output term-subst (TVr { tvrIdent = 0 }) _ e = e+subst (TVr { tvrIdent = i }) _ e | isEmptyId i = e subst (TVr { tvrIdent = i }) w e = doSubst' False False (msingleton i w) (\n -> n `member` (freeVars w `union` freeVars e :: IdSet)) e -- | Identitcal to 'subst' except that it substitutes inside the local types@@ -73,7 +73,7 @@ -- transient terms for typechecking. subst' :: TVr -> E -> E -> E-subst' (TVr { tvrIdent = 0 }) _ e = e+subst' (TVr { tvrIdent = i }) _ e | isEmptyId i = e subst' (TVr { tvrIdent = (i) }) w e = doSubst' True False (msingleton i w) (\n -> n `member` (freeVars w `union` freeVars e :: IdSet)) e @@ -145,10 +145,10 @@ alts <- local r (mapM da $ eCaseAlts ec) nty <- f (eCaseType ec) return $ caseUpdate ec { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts, eCaseType = nty }- lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == 0 || (allShadow && n `notElem` freeVars e) = do+ lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | isEmptyId n || (allShadow && n `notElem` freeVars e) = do t' <- f t e' <- local (\(s,m) -> (Set.insert n s, mdelete n m)) $ f e- return $ lam (tvr { tvrIdent = 0, tvrType = t'}) e'+ return $ lam (tvr { tvrIdent = emptyId, tvrType = t'}) e' lp lam tvr e = do (tv,r) <- ntvr Set.empty tvr e' <- local r $ f e@@ -160,7 +160,7 @@ local r $ f ts ((t',r):rs) vs = Set.fromList [ tvrIdent x | x <- ts ] - ntvr xs tvr@(TVr { tvrIdent = 0, tvrType = t}) = do+ ntvr xs tvr@(TVr { tvrIdent = i, tvrType = t}) | isEmptyId i = do t' <- f t let nvr = (tvr { tvrType = t'}) return (nvr,id)@@ -184,8 +184,8 @@ -eAp (EPi t b) e = if tvrIdent t == 0 then b else subst t e b-eAp (ELam t b) e = if tvrIdent t == 0 then b else subst t e b+eAp (EPi t b) e = if isEmptyId (tvrIdent t) then b else subst t e b+eAp (ELam t b) e = if isEmptyId (tvrIdent t) then b else subst t e b --eAp (EPrim n es t@(EPi _ _)) b = EPrim n (es ++ [b]) (eAp t b) -- only apply if type is pi-like eAp (ELit lc@LitCons { litArgs = es, litType = (EPi t r) }) b = ELit lc { litArgs = es ++ [b], litType = subst t b r } eAp (ELit LitCons { litArgs = es, litAliasFor = Just af }) b = foldl eAp af (es ++ [b])@@ -253,10 +253,10 @@ alts <- (mapM da $ eCaseAlts ec) nty <- inType (f $ eCaseType ec) return $ caseUpdate ec { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts, eCaseType = nty }- lp lam tvr@(TVr { tvrIdent = 0, tvrType = t}) e = do+ lp lam tvr@(TVr { tvrIdent = i, tvrType = t}) e | isEmptyId i = do t' <- inType (f t) e' <- f e- return $ lam (tvr { tvrIdent = 0, tvrType = t'}) e'+ return $ lam (tvr { tvrIdent = emptyId, tvrType = t'}) e' lp lam tvr e = do (tv,r) <- ntvr Set.empty tvr e' <- local r $ f e@@ -277,7 +277,7 @@ litSMapM (LitInt n t) = do t' <- inType $ f t return $ LitInt n t'- ntvr xs tvr@(TVr { tvrIdent = 0, tvrType = t}) = do+ ntvr xs tvr@(TVr { tvrIdent = i, tvrType = t}) | isEmptyId i = do t' <- inType (f t) let nvr = (tvr { tvrType = t'}) return (nvr,id)
src/E/Traverse.hs view
@@ -57,7 +57,12 @@ z (ESort aa) = do return $ ESort aa z (ELit lc@LitCons { litArgs = es, litType = t }) = do t' <- g t; es' <- mapM f es; return $ ELit lc { litArgs = es', litType = t' } z (ELit aa) = do aa <- T.mapM g aa; return $ ELit aa- z ELetRec { eDefs = aa, eBody = ab } = do aa <- mapM (\x -> do x <- (do (aa,ab) <- return x; aa <- mapmTvr g aa;ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab+ z ELetRec { eDefs = aa, eBody = ab } = do aa <- mapM (\(aa,ab) ->do aa <- mapmTvr g aa+ ab <- f ab+ return (aa,ab))+ aa+ ab <- f ab+ return $ ELetRec aa ab z ec@ECase {} = do e' <- f $ eCaseScrutinee ec b' <- T.mapM g (eCaseBind ec)@@ -149,12 +154,12 @@ return (Alt (LitInt n t') l') localSubst :: (IdMap E) -> IdNameT (Reader (IdMap E)) a -> IdNameT (Reader (IdMap E)) a localSubst ex action = do local (ex `mappend`) action- ntvr _ fg tv@TVr { tvrIdent = 0, tvrType = t} = do+ ntvr _ fg tv@TVr { tvrIdent = i, tvrType = t} | isEmptyId i = do t' <- fg t return (mempty,tv { tvrType = t'}) ntvr ralways fg tv@(TVr { tvrIdent = n, tvrType = t}) = do --n' <- if n > 0 && (not ralways || isValidAtom n) then uniqueName n else newName- n' <- if not (isEtherialId n) && (not ralways || isValidAtom n) then uniqueName n else newName+ n' <- if not (isEtherialId n) && (not ralways || idIsNamed n) then uniqueName n else newName --n' <- if (not ralways || isValidAtom n) then uniqueName n else newName t' <- fg t let tv' = tv { tvrIdent = n', tvrType = t' }
src/E/Type.hs view
@@ -159,7 +159,7 @@ showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t instance Show a => Show (TVr' a) where- showsPrec n TVr { tvrIdent = 0, tvrType = e} = showParen (n > 10) $ showString "_::" . shows e+ showsPrec n TVr { tvrIdent = emptyId, tvrType = e} = showParen (n > 10) $ showString "_::" . shows e showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of Just n -> shows n . showString "::" . shows e Nothing -> shows x . showString "::" . shows e@@ -202,7 +202,7 @@ litBinds (LitCons { litArgs = xs } ) = xs litBinds _ = [] -patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr 0 (EVar a)) (EVar b)+patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr emptyId (EVar a)) (EVar b) patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af } patToLitEE (LitInt x t) = ELit $ LitInt x t @@ -245,7 +245,7 @@ eHash = ESort EHash tVr x y = tvr { tvrIdent = x, tvrType = y }-tvr = TVr { tvrIdent = 0, tvrType = Unknown, tvrInfo = Info.empty }+tvr = TVr { tvrIdent = emptyId, tvrType = Unknown, tvrInfo = Info.empty } combBody_u f r@Comb{combBody = x} = r{combBody = f x} combHead_u f r@Comb{combHead = x} = r{combHead = f x}
src/E/TypeAnalysis.hs view
@@ -261,7 +261,7 @@ return $ progCombinators_s nds prog -repi (ELit LitCons { litName = n, litArgs = [a,b] }) | n == tc_Arrow = EPi tvr { tvrIdent = 0, tvrType = repi a } (repi b)+repi (ELit LitCons { litName = n, litArgs = [a,b] }) | n == tc_Arrow = EPi tvr { tvrIdent = emptyId, tvrType = repi a } (repi b) repi e = runIdentity $ emapE (return . repi ) e {-@@ -408,7 +408,7 @@ ne = emptyCase { eCaseScrutinee = EVar a, eCaseAlts = map calt rules,- eCaseBind = a { tvrIdent = 0 },+ eCaseBind = a { tvrIdent = emptyId }, eCaseType = ct } calt rule@Rule { ruleArgs = ~(arg:rs) } = Alt vp (substMap (fromList [ (tvrIdent v,EVar r) | ~(EVar v) <- rs | r <- ras ]) $ ruleBody rule) where
src/E/TypeCheck.hs view
@@ -188,7 +188,7 @@ inferType' ds e = inferType dataTable ds e prettyE = ePrettyEx rfc e = withContextDoc (text "fullCheck:" </> prettyE e) (fc e >>= strong')- rfc' nds e = withContextDoc (text "fullCheck:" </> prettyE e) (inferType' nds e >>= strong')+ rfc' nds e = withContextDoc (text "fullCheck(nested):" </> prettyE e) (inferType' nds e >>= strong') strong' e = withContextDoc (text "Strong:" </> prettyE e) $ strong ds e fc s@(ESort _) = return $ getType s fc (ELit lc@LitCons {}) | let lc' = updateLit dataTable lc, litAliasFor lc /= litAliasFor lc' = fail $ "Alias not correct: " ++ show (lc, litAliasFor lc')@@ -212,7 +212,7 @@ return t' fc e@(ELit _) = let t = getType e in valid t >> return t -- Lemmih 08.11.26: Why are unnamed bindings errors in this case?- fc (EVar (TVr { tvrIdent = 0 })) = fail "variable with nothing!"+ fc (EVar (TVr { tvrIdent = i })) | isEmptyId i = fail "variable with nothing!" fc (EVar (TVr { tvrType = t})) = valid t >> strong' t fc (EPi (TVr { tvrIdent = n, tvrType = at}) b) = do ESort a <- rfc at@@ -231,7 +231,7 @@ a' <- rfc a if a' == tBox then return tBox else strong' (eAp a' b) fc (ELetRec vs e) = do- let ck (TVr { tvrIdent = 0 },_) = fail "binding of empty var"+ let ck (TVr { tvrIdent = i },_) | isEmptyId i = fail "binding of empty var" ck (tv@(TVr { tvrType = t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text " = ", parens $ prettyE e ]) $ do when (getType t == eHash && not (isEPi t)) $ fail $ "Let binding unboxed value: " ++ show (tv,e) valid' nds t@@ -282,7 +282,7 @@ mapM_ verifyPats' xs when (hasRepeatUnder litHead xs) $ fail "Duplicate case alternatives" - verifyPats' LitCons { litArgs = xs } = when (hasRepeatUnder id (filter (/= 0) $ map tvrIdent xs)) $ fail "Case pattern is non-linear"+ verifyPats' LitCons { litArgs = xs } = when (hasRepeatUnder id (filter (not . isEmptyId) $ map tvrIdent xs)) $ fail "Case pattern is non-linear" verifyPats' _ = return () eqAll ts = withContextDoc (text "eqAll" </> list (map prettyE ts)) $ foldl1M_ eq ts@@ -301,9 +301,9 @@ eq' nds t1 t2 = do e1 <- strong nds (t1) e2 <- strong nds (t2)- case typesCompatable dataTable e1 e2 of+ case typesCompatable e1 e2 of Right () -> return (e1)- Left s -> failDoc $ hsep [text "eq:",text s, align $ vcat [ prettyE (e1),prettyE (e2) ] ]+ Left s -> failDoc $ text "eq:" <+> align $ vcat [ text s, prettyE (e1), prettyE (e2) ] fceq nds e1 t2 = do withContextDoc (hsep [text "fceq:", align $ vcat [parens $ prettyE e1, parens $ prettyE t2]]) $ do t1 <- inferType' nds e1@@ -360,12 +360,12 @@ typeInfer'' dataTable ds e = rfc e where inferType' ds e = typeInfer'' dataTable ds e rfc e = withContextDoc (text "fullCheck':" </> ePrettyEx e) (fc e >>= strong')- rfc' nds e = withContextDoc (text "fullCheck':" </> ePrettyEx e) (inferType' nds e >>= strong')+ rfc' nds e = withContextDoc (text "fullCheck'(nested):" </> ePrettyEx e) (inferType' nds e >>= strong') strong' e = withContextDoc (text "Strong':" </> ePrettyEx e) $ strong ds e fc s@ESort {} = return $ getType s fc (ELit LitCons { litType = t }) = strong' t fc e@ELit {} = strong' (getType e)- fc (EVar TVr { tvrIdent = 0 }) = fail "variable with nothing!"+ fc (EVar TVr { tvrIdent = i }) | isEmptyId i = fail "variable with nothing!" fc (EVar TVr { tvrType = t}) = strong' t fc (EPi TVr { tvrIdent = n, tvrType = at} b) = do ESort a <- rfc at@@ -404,7 +404,7 @@ -> E -- ^ pattern to match -> E -- ^ input expression -> m [(TVr,E)]-match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () (-2::Int)) where+match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 () (etherialIds)) where bvs :: IdSet bvs = fromList (map tvrIdent vs) @@ -424,16 +424,16 @@ un t t' mm c un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) mm c | i == j = un t u mm c- un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) mm c | i < 0 || j < 0 = fail "Expressions don't match"+ un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) mm c | isEtherialId i || isEtherialId j = fail "Expressions don't match" un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b mm c | i `member` bvs = tell (Seq.single (tvr,b)) | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b un a (EVar tvr) mm c | Just b <- lup (tvrIdent tvr), not $ isEVar b = un a b mm c un a b _ _ = fail $ "Expressions do not unify: " ++ show a ++ show b- lam va ea vb eb mm c = do- un (tvrType va) (tvrType vb) mm c- un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm (c - 2)+ lam va ea vb eb mm (c:cs) = do+ un (tvrType va) (tvrType vb) mm (c:cs)+ un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) mm cs $(derive makeUpdate ''TcEnv) instance ContextMonad String Tc where@@ -449,7 +449,7 @@ fc s@ESort {} = return $ getType s fc (ELit LitCons { litType = t }) = strong' t fc e@ELit {} = strong' (getType e)- fc (EVar TVr { tvrIdent = 0 }) = fail "variable with nothing!"+ fc (EVar TVr { tvrIdent = i }) | isEmptyId i = fail "variable with nothing!" fc (EVar TVr { tvrType = t}) = strong' t fc (EPi TVr { tvrIdent = n, tvrType = at} b) = do ESort a <- rfc at
src/E/Values.hs view
@@ -111,18 +111,29 @@ } -eCaseTup e vs w = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr 0 (getType e)), eCaseType = getType w, eCaseAlts = [Alt litCons { litName = nameTuple DataConstructor (length vs), litArgs = vs, litType = getType e } w] }-eCaseTup' e vs w = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr 0 (getType e)), eCaseType = getType w, eCaseAlts = [Alt litCons { litName = unboxedNameTuple DataConstructor (length vs), litArgs = vs, litType = getType e} w] }+eCaseTup e vs w = caseUpdate emptyCase { eCaseScrutinee = e+ , eCaseBind = (tVr emptyId (getType e))+ , eCaseType = getType w+ , eCaseAlts = [Alt litCons { litName = nameTuple DataConstructor (length vs)+ , litArgs = vs+ , litType = getType e } w]+ }+eCaseTup' e vs w = caseUpdate emptyCase { eCaseScrutinee = e+ , eCaseBind = (tVr emptyId (getType e))+ , eCaseType = getType w+ , eCaseAlts = [Alt litCons { litName = unboxedNameTuple DataConstructor (length vs)+ , litArgs = vs+ , litType = getType e} w] } eJustIO w x = eTuple' [w,x] -- ELit litCons { litName = dc_JustIO, litArgs = [w,x], litType = ELit litCons { litName = tc_IOResult, litArgs = [getType x], litType = eStar } } tIO t = ELit (litCons { litName = tc_IO, litArgs = [t], litType = eStar }) -eCase e alts@(alt:_) Unknown = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr 0 (getType e)), eCaseType = getType alt, eCaseAlts = alts }-eCase e alts els = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr 0 (getType e)), eCaseDefault = Just els, eCaseAlts = alts, eCaseType = getType els }+eCase e alts@(alt:_) Unknown = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseType = getType alt, eCaseAlts = alts }+eCase e alts els = caseUpdate emptyCase { eCaseScrutinee = e, eCaseBind = (tVr emptyId (getType e)), eCaseDefault = Just els, eCaseAlts = alts, eCaseType = getType els } -- | This takes care of types right away, it simplifies various other things to do it this way. eLet :: TVr -> E -> E -> E-eLet TVr { tvrIdent = 0 } _ e' = e'+eLet TVr { tvrIdent = i } _ e' | isEmptyId i = e' eLet t@(TVr { tvrType = ty}) e e' | sortKindLike ty && isAtomic e = subst t e e' | sortKindLike ty = ELetRec [(t,e)] (typeSubst mempty (msingleton (tvrIdent t) e) e')@@ -136,7 +147,7 @@ substLet :: [(TVr,E)] -> E -> E substLet ds e = ans where- (as,nas) = partition (isAtomic . snd) (filter ((/= 0) . tvrIdent . fst) ds)+ (as,nas) = partition (isAtomic . snd) (filter ((not . isEmptyId) . tvrIdent . fst) ds) tas = filter (sortKindLike . tvrType . fst) nas ans = eLetRec (as ++ nas) (typeSubst' (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- as]) (fromList [ (n,e) | (TVr { tvrIdent = n },e) <- tas]) e) @@ -144,7 +155,7 @@ substLet' :: [(TVr,E)] -> E -> E substLet' ds' e = ans where (hh,ds) = partition (isUnboxed . tvrType . fst) ds'- nas = filter ((/= 0) . tvrIdent . fst) ds+ nas = filter ((not . isEmptyId) . tvrIdent . fst) ds tas = filter (sortKindLike . tvrType . fst) nas ans = case (nas,tas) of ([],_) -> hhh hh $ e@@ -161,7 +172,10 @@ prim_seq a b | isWHNF a = b-prim_seq a b = caseUpdate emptyCase { eCaseScrutinee = a, eCaseBind = (tVr 0 (getType a)), eCaseDefault = Just b, eCaseType = getType b }+prim_seq a b = caseUpdate emptyCase { eCaseScrutinee = a+ , eCaseBind = (tVr emptyId (getType a))+ , eCaseDefault = Just b+ , eCaseType = getType b } prim_unsafeCoerce e t = p e' where
src/E/WorkerWrapper.hs view
@@ -17,6 +17,7 @@ import Info.Types import Name.Name import Name.Names+import Name.Id (isEmptyId, fromId, toId) import Stats hiding(null) import Support.CanType import Util.SetLike@@ -45,7 +46,7 @@ cpr = maybe Top id (Info.lookup (tvrInfo mtvr)) Demand.DemandSignature _ (_ Demand.:=> sa) = maybe Demand.absSig id (Info.lookup (tvrInfo mtvr)) ans = f e ( sa ++ repeat Demand.lazy) cpr []- g t@TVr { tvrIdent = 0 } _ = (Absent,t)+ g t@TVr { tvrIdent = i } _ | isEmptyId i = (Absent,t) g t (Demand.S subs) | Just con <- getProduct dataTable tt = (Cons con (as con),t) where
src/Fixer/Fixer.hs view
@@ -1,6 +1,30 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE BangPatterns, ExistentialQuantification, DeriveDataTypeable #-} -- find fixpoint of constraint problem +{- 2009.01.05: Lemmih++This may be obvious to a lot of people but it certainly wasn't obvious to me.++The following module help you solve problems that involve iterating over+a piece of data until some steady-state (aka. a fixpoint) is found.++One example problem would be dead-code elimination. To remove all dead+functions and function arguments, we have to mark everything that+could possibly be alive (we necessarily have to be conservative).+This is done in two steps:+1) Walk through the code and make a note of all the dependencies+ (eg. function 'x' uses function 'y' and function 'z'). The dependencies+ are then handed over to the fixpoint solver.+2) The fixpoint solver iterate over all the data and use the dependencies+ to propagate the usage information. That is, if 'x' is used then 'y' and 'z'+ are as well. The next iteration will deal with the dependencies of 'y' and 'z'.++Once there's no more usage information to propagate, we know we've found our fixpoint.+There are several other problems that require fixpoint iteration. Perhaps the most+distinguished is the heap points-to analysis we use to eliminate eval/apply calls.++-}+ module Fixer.Fixer( Fixable(..), Value(),@@ -155,7 +179,6 @@ modifiedSuperSetOf UnionValue {} _ _ = Rule $ fail "Fixer: You cannot modify a union value" isSuperSetOf :: Fixable a => Value a -> Value a -> Rule-(IV rv) `isSuperSetOf` (ConstValue v2) = Rule $ propagateValue v2 rv (IV rv) `isSuperSetOf` v2 = Rule $ addAction v2 (\x -> propagateValue x rv) (IOValue iov) `isSuperSetOf` v2 = Rule $ iov >>= unRule . (`isSuperSetOf` v2) ConstValue v1 `isSuperSetOf` ConstValue v2 | v2 `lte` v1 = Rule $ return ()@@ -207,8 +230,7 @@ to <- readIORef todo if Set.null to then return () else do vars <- readIORef vars- let f _ tl n | (tl::Int) `seq` n `seq` False = undefined- f [] tl n | n > 0, tl /= 0 = do+ let f [] !tl !n | n > 0, tl /= 0 = do vs <- readIORef todo writeIORef todo Set.empty mputStr "(" >> mputStr (show n) >> mputStr ")" >> mFlush@@ -237,7 +259,7 @@ Just (_,h) -> hFlush h mputStr $ "Finding fixpoint for " ++ mstring ++ ": " ++ "[" ++ show (Set.size to) ++ "]" mFlush- f (Set.toList to) (-1) (0::Int)+ f (Set.toList to) (-1::Int) (0::Int)
src/FlagDump.hs view
@@ -24,6 +24,7 @@ | Dcons -- ^ data constructors | Decls -- ^ processed declarations | Defs -- ^ Show all defined names in a module+ | DepGraph -- ^ Dump module dependancy graph to deps.dot | Derived -- ^ show generated derived instances | EAlias -- ^ show expanded aliases | EInfo -- ^ show info tags on all bound variables@@ -54,7 +55,7 @@ | RulesSpec -- ^ show specialization rules | SccModules -- ^ show strongly connected modules in dependency order | Sigenv -- ^ initial signature environment- | SquareStats -- ^ use square corners rather than curved ones, for compatibility+ | SquareStats -- ^ use square corners (this is now the only option, though) | Srcsigs -- ^ processed signatures from source code | Stats -- ^ show extra information about stuff | Steps -- ^ show interpreter go@@ -73,6 +74,7 @@ show Imports = "imports" show Exports = "exports" show SccModules = "scc-modules"+ show DepGraph = "dep-graph" show Defs = "defs" show Kind = "kind" show KindSteps = "kind-steps"@@ -242,6 +244,8 @@ one "no-grin-normalized" = Right $ Set.delete GrinNormalized one "grin" = Right $ Set.insert Grin one "no-grin" = Right $ Set.delete Grin+one "dep-graph" = Right $ Set.insert DepGraph+one "no-dep-graph" = Right $ Set.delete DepGraph one x = Left x {-# NOINLINE process #-}@@ -250,6 +254,6 @@ f (Left x) (s,xs) = (s,x:xs) {-# NOINLINE helpMsg #-}-helpMsg = "\n-- Front End --\n defs\n Show all defined names in a module\n derived\n show generated derived instances\n exports\n show which names are exported from each module\n imports\n show in scope names for each module\n parsed\n parsed code\n preprocessed\n code after preprocessing/deliting\n renamed\n code after uniqueness renaming\n scc-modules\n show strongly connected modules in dependency order\n\n-- Type Checker --\n all-dcons\n show unified data constructor table\n all-kind\n show unified kind table after everything has been typechecked\n all-types\n show unified type table, after everything has been typechecked\n aspats\n show as patterns\n bindgroups\n show bindgroups\n boxy-steps\n show step by step what the type inferencer is doing\n class\n detailed information on each class\n class-summary\n summary of all classes\n dcons\n data constructors\n decls\n processed declarations\n instance\n show instances\n kind\n show results of kind inference for each module\n kind-steps\n show steps of kind inference\n program\n impl expls, the whole shebang.\n sigenv\n initial signature environment\n srcsigs\n processed signatures from source code\n types\n display unified type table containing all defined names\n tyvar\n show original tyvars rather than renaming them.\n\n-- Intermediate code --\n core\n show intermediate core code\n core-afterlift\n show final core before writing ho file\n core-beforelift\n show core before lambda lifting\n core-initial\n show core right after E.FromHs conversion\n core-mangled\n de-typed core right before it is converted to grin\n core-mini\n show details even when optimizing individual functions\n core-pass\n show each iteration of code while transforming\n core-steps\n show what happens in each pass\n datatable\n show data table of constructors\n e-alias\n show expanded aliases\n e-info\n show info tags on all bound variables\n e-size\n print the size of E after each pass\n e-verbose\n print very verbose version of E code always\n optimization-stats\n show combined stats of optimization passes\n rules\n show all user rules and catalysts\n rules-spec\n show specialization rules\n\n-- Grin code --\n eval\n show detailed eval inlining info\n grin\n show final grin code\n grin-graph\n print dot file of final grin code to outputname_grin.dot\n grin-initial\n grin right after conversion from core\n grin-normalized\n grin right after first normalization\n grin-pass\n show each iteration of code while transforming\n grin-posteval\n show grin code just before eval/apply inlining\n grin-preeval\n show grin code just before eval/apply inlining\n grin-steps\n show what happens in each transformation\n steps\n show interpreter go\n tags\n list of all tags and their types\n\n-- General --\n html\n use html escape codes in output\n progress\n show basic progress indicators\n square-stats\n use square corners rather than curved ones, for compatibility\n stats\n show extra information about stuff\n verbose\n progress\n veryverbose\n progress stats\n"-helpFlags = ["all-dcons", "all-kind", "all-types", "aspats", "bindgroups", "boxy-steps", "class", "class-summary", "core", "core-afterlift", "core-beforelift", "core-initial", "core-mangled", "core-mini", "core-pass", "core-steps", "datatable", "dcons", "decls", "defs", "derived", "e-alias", "e-info", "e-size", "e-verbose", "eval", "exports", "grin", "grin-graph", "grin-initial", "grin-normalized", "grin-pass", "grin-posteval", "grin-preeval", "grin-steps", "html", "imports", "instance", "kind", "kind-steps", "optimization-stats", "parsed", "preprocessed", "program", "progress", "renamed", "rules", "rules-spec", "scc-modules", "sigenv", "square-stats", "srcsigs", "stats", "steps", "tags", "the", "types", "tyvar", "verbose", "veryverbose"]+helpMsg = "\n-- Front End --\n defs\n Show all defined names in a module\n dep-graph\n Dump module dependancy graph to deps.dot\n derived\n show generated derived instances\n exports\n show which names are exported from each module\n imports\n show in scope names for each module\n parsed\n parsed code\n preprocessed\n code after preprocessing/deliting\n renamed\n code after uniqueness renaming\n scc-modules\n show strongly connected modules in dependency order\n\n-- Type Checker --\n all-dcons\n show unified data constructor table\n all-kind\n show unified kind table after everything has been typechecked\n all-types\n show unified type table, after everything has been typechecked\n aspats\n show as patterns\n bindgroups\n show bindgroups\n boxy-steps\n show step by step what the type inferencer is doing\n class\n detailed information on each class\n class-summary\n summary of all classes\n dcons\n data constructors\n decls\n processed declarations\n instance\n show instances\n kind\n show results of kind inference for each module\n kind-steps\n show steps of kind inference\n program\n impl expls, the whole shebang.\n sigenv\n initial signature environment\n srcsigs\n processed signatures from source code\n types\n display unified type table containing all defined names\n tyvar\n show original tyvars rather than renaming them.\n\n-- Intermediate code --\n core\n show intermediate core code\n core-afterlift\n show final core before writing ho file\n core-beforelift\n show core before lambda lifting\n core-initial\n show core right after E.FromHs conversion\n core-mangled\n de-typed core right before it is converted to grin\n core-mini\n show details even when optimizing individual functions\n core-pass\n show each iteration of code while transforming\n core-steps\n show what happens in each pass\n datatable\n show data table of constructors\n e-alias\n show expanded aliases\n e-info\n show info tags on all bound variables\n e-size\n print the size of E after each pass\n e-verbose\n print very verbose version of E code always\n optimization-stats\n show combined stats of optimization passes\n rules\n show all user rules and catalysts\n rules-spec\n show specialization rules\n\n-- Grin code --\n eval\n show detailed eval inlining info\n grin\n show final grin code\n grin-graph\n print dot file of final grin code to outputname_grin.dot\n grin-initial\n grin right after conversion from core\n grin-normalized\n grin right after first normalization\n grin-pass\n show each iteration of code while transforming\n grin-posteval\n show grin code just before eval/apply inlining\n grin-preeval\n show grin code just before eval/apply inlining\n grin-steps\n show what happens in each transformation\n steps\n show interpreter go\n tags\n list of all tags and their types\n\n-- General --\n html\n use html escape codes in output\n progress\n show basic progress indicators\n square-stats\n use square corners (this is now the only option, though)\n stats\n show extra information about stuff\n verbose\n progress\n veryverbose\n progress stats\n"+helpFlags = ["all-dcons", "all-kind", "all-types", "aspats", "bindgroups", "boxy-steps", "class", "class-summary", "core", "core-afterlift", "core-beforelift", "core-initial", "core-mangled", "core-mini", "core-pass", "core-steps", "datatable", "dcons", "decls", "defs", "dep-graph", "derived", "e-alias", "e-info", "e-size", "e-verbose", "eval", "exports", "grin", "grin-graph", "grin-initial", "grin-normalized", "grin-pass", "grin-posteval", "grin-preeval", "grin-steps", "html", "imports", "instance", "kind", "kind-steps", "optimization-stats", "parsed", "preprocessed", "program", "progress", "renamed", "rules", "rules-spec", "scc-modules", "sigenv", "square-stats", "srcsigs", "stats", "steps", "tags", "the", "types", "tyvar", "verbose", "veryverbose"]
src/FlagOpts.hs view
@@ -12,7 +12,6 @@ | Defaulting -- ^ perform defaulting of ambiguous types | Ffi -- ^ support foreign function declarations | FloatIn -- ^ perform float inward transform- | 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 | Lint -- ^ perform lots of extra type checks@@ -26,6 +25,7 @@ | TypeAnalysis -- ^ perhaps a basic points-to analysis on types right after method generation | UnboxedTuples -- ^ allow unboxed tuple syntax to be recognized | UnboxedValues -- ^ allow unboxed value syntax+ | Unsafe -- ^ disable runtime assertions | Wrapper -- ^ wrap main in exception handler deriving(Eq,Ord,Bounded) @@ -37,6 +37,7 @@ show Ffi = "ffi" show Cpp = "cpp" show M4 = "m4"+ show Unsafe = "unsafe" show MonomorphismRestriction = "monomorphism-restriction" show Defaulting = "defaulting" show Lint = "lint"@@ -47,7 +48,6 @@ show Cpr = "cpr" show TypeAnalysis = "type-analysis" show GlobalOptimize = "global-optimize"- show FullInt = "full-int" show Wrapper = "wrapper" show Boehm = "boehm" show Profile = "profile"@@ -80,6 +80,8 @@ one "no-debug" = Right $ Set.delete Debug one "wrapper" = Right $ Set.insert Wrapper one "no-wrapper" = Right $ Set.delete Wrapper+one "unsafe" = Right $ Set.insert Unsafe+one "no-unsafe" = Right $ Set.delete Unsafe one "float-in" = Right $ Set.insert FloatIn one "no-float-in" = Right $ Set.delete FloatIn one "unboxed-values" = Right $ Set.insert UnboxedValues@@ -90,8 +92,6 @@ one "no-unboxed-tuples" = Right $ Set.delete UnboxedTuples one "global-optimize" = Right $ Set.insert GlobalOptimize one "no-global-optimize" = Right $ Set.delete GlobalOptimize-one "full-int" = Right $ Set.insert FullInt-one "no-full-int" = Right $ Set.delete FullInt one "default" = Right $ foldr (.) id [ f | Right f <- [ one "inline-pragmas",one "rules",one "wrapper",one "float-in",one "strictness",one "defaulting",one "type-analysis",one "monomorphism-restriction",one "boxy",one "eval-optimize",one "global-optimize"]] one "negate" = Right $ Set.insert Negate one "no-negate" = Right $ Set.delete Negate@@ -109,6 +109,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 profile\n enable profiling code in generated executable\n raw\n just evaluate main to WHNF and nothing else.\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", "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 unsafe\n disable runtime assertions\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 profile\n enable profiling code in generated executable\n raw\n just evaluate main to WHNF and nothing else.\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", "global-optimize", "inline-pragmas", "lint", "m4", "monomorphism-restriction", "negate", "profile", "raw", "rules", "strictness", "type-analysis", "unboxed-tuples", "unboxed-values", "unsafe", "wrapper"]
src/FrontEnd/Class.hs view
@@ -4,7 +4,6 @@ ClassHierarchy, ClassRecord(..), isClassRecord,- isClassAliasRecord, instanceName, defaultInstanceName, printClassSummary,@@ -12,7 +11,6 @@ asksClassRecord, classRecords, makeClassHierarchy,- scatterAliasInstances, derivableClasses, makeInstanceEnv, InstanceEnv(..),@@ -21,11 +19,12 @@ import Data.DeriveTH import Data.Derive.All+import Control.Arrow (first) import Control.Monad.Identity import Control.Monad.Writer import Data.Monoid import Data.Generics-import Data.List(nub)+import Data.List(nub,(\\)) import Text.PrettyPrint.ANSI.Leijen(Doc()) import qualified Data.Map as Map import Debug.Trace@@ -39,18 +38,17 @@ import FrontEnd.Tc.Type import FrontEnd.Utils import FrontEnd.HsSyn-import Support.MapBinaryInstance import Maybe import Monad import Name.Name import Name.Names import Support.CanType-import PrimitiveOperators(primitiveInsts) import Support.FreeVars import Util.Gen import Util.HasSize import Util.Inst() import Support.Tickle+import Options (verbose) -------------------------------------------------------------------------------- @@ -66,10 +64,17 @@ instance PPrint a (Qual Pred) => PPrint a Inst where pprint Inst { instHead = h, instAssocs = [] } = pprint h- pprint Inst { instHead = h, instAssocs = as } = pprint h <+> text "where" <$> vcat [ text " type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma | (n,_,ts,sigma) <- as]+ pprint Inst { instHead = h, instAssocs = as } = + pprint h <+> text "where" + <$> vcat [ text " type" <+> pprint n <+> text "_" <+> hsep (map pprint ts)+ <+> text "=" <+> pprint sigma+ | (n,_,ts,sigma) <- as] -emptyInstance = Inst { instDerived = False, instSrcLoc = bogusASrcLoc, instHead = error "emptyInstance", instAssocs = [] }+emptyInstance = Inst { instDerived = False,+ instSrcLoc = bogusASrcLoc,+ instHead = error "emptyInstance",+ instAssocs = [] } -- | a class record is either a class along with instances, or just instances. -- you can tell the difference by the presence of the classArgs field@@ -80,16 +85,9 @@ classSupers :: [Class], classInsts :: [Inst], classAssumps :: [(Name,Sigma)], -- ^ method signatures+ classDefaults :: [(Name,Name)], -- ^ default methods and their body names classAssocs :: [(Tycon,[Tyvar],Maybe Sigma)] }- | ClassAliasRecord { className :: Class,- classSrcLoc :: SrcLoc,- classArgs :: [Tyvar],- classSupers :: [Class],- classInsts :: [Inst],- classClasses :: [Class],- classMethodMap :: Map.Map Name Class - } deriving Show $(derive makeBinary ''ClassRecord) $(derive makeIs ''ClassRecord)@@ -101,32 +99,23 @@ classArgs = [], classInsts = [], classAssumps = [],+ classDefaults = [], classAssocs = [] } -combineClassRecords cra@(ClassRecord {}) crb@(ClassRecord {}) | className cra == className crb = ClassRecord {+-- SamB 2009-01-17: Why all the snubbing? Most of these fields should be blank on one side shouldn't they?+combineClassRecords cra@(ClassRecord {}) crb@(ClassRecord {})+ | className cra == className crb = ClassRecord { className = className cra, classSrcLoc = if classSrcLoc cra == bogusASrcLoc then classSrcLoc crb else classSrcLoc cra, classSupers = snub $ classSupers cra ++ classSupers crb, classInsts = snub $ classInsts cra ++ classInsts crb, classAssumps = snubFst $ classAssumps cra ++ classAssumps crb, classAssocs = snubUnder fst3 $ classAssocs cra ++ classAssocs crb,+ classDefaults = snub $ classDefaults cra ++ classDefaults crb, classArgs = if null (classArgs cra) then classArgs crb else classArgs cra } -combineClassRecords cra@(ClassAliasRecord {}) crb@(ClassRecord {}) | className cra == className crb = ClassAliasRecord {- className = className cra,- classSrcLoc = if classSrcLoc cra == bogusASrcLoc then classSrcLoc crb else classSrcLoc cra,- classSupers = snub $ classSupers cra ++ classSupers crb,- classInsts = snub $ classInsts cra ++ classInsts crb,- classArgs = if null (classArgs cra) then classArgs crb else classArgs cra,- classClasses = classClasses cra,- classMethodMap = classMethodMap cra-}--combineClassRecords cra@(ClassRecord {}) crb@(ClassAliasRecord {}) = combineClassRecords crb cra-combineClassRecords cra crb = error ("combineClassRecords ("++show cra++") ("++show crb++")")- newtype InstanceEnv = InstanceEnv { instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) } makeInstanceEnv :: ClassHierarchy -> InstanceEnv@@ -145,8 +134,8 @@ deriving (HasSize) instance Binary ClassHierarchy where- get = fmap ClassHierarchy getMap- put (ClassHierarchy ch) = putMap ch+ get = fmap ClassHierarchy get+ put (ClassHierarchy ch) = put ch instance Monoid ClassHierarchy where mempty = ClassHierarchy mempty@@ -189,12 +178,6 @@ unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers) unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts)) putStrLn ""- f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do- putStrLn $ "-- class: " ++ show cname- unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers)- unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts))- unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes)- putStrLn "" @@ -203,25 +186,22 @@ printClassDetails :: (Name, ClassRecord) -> IO () printClassDetails (cname, cr) = do let args = classArgs cr; supers = classSupers cr; insts = classInsts cr;- -- possibly absent+ defaults = classDefaults cr methodAssumps = classAssumps cr assocs = classAssocs cr- classes = classClasses cr putStrLn "..........." putStrLn $ "class: " ++ hsep (pprint cname:map pprint args) putStr $ "super classes:" pnone supers $ do putStrLn $ " " ++ (intercalate " " (map show supers)) putStr $ "instances:" pnone insts $ putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)+ putStr $ "default method implementations:"+ pnone defaults $ putStr $ "\n" ++ (unlines $ map pretty defaults) when (isClassRecord cr) $ do putStr $ "method signatures:" pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps) putStr $ "associated types:" pnone assocs $ putStrLn $ "\n" ++ (unlines $ map (show . passoc) assocs)- when (isClassAliasRecord cr) $ do- putStr $ "alias for:"- pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes))- putStr "\n" pnone [] f = putStrLn " none" pnone xs f = f passoc (nk,as,mt) = text "type" <+> pprint nk <+> hsep (map pprint as) <> case mt of@@ -240,14 +220,19 @@ Just r -> ClassHierarchy $ Map.insert c (f r) h addOneInstanceToHierarchy :: ClassHierarchy -> Inst -> ClassHierarchy-addOneInstanceToHierarchy ch inst@Inst { instHead = cntxt :=> IsIn className _ } = modifyClassRecord f className ch where+addOneInstanceToHierarchy ch inst@Inst { instHead = cntxt :=> IsIn className _ } + = modifyClassRecord f className ch+ where f c = c { classInsts = inst:classInsts c } hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst] hsInstDeclToInst kt (HsInstDecl sloc qType decls) | length classKind == length argTypeKind, and subsumptions- = return [emptyInstance { instSrcLoc = sloc, instDerived = False, instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }]+ = return [emptyInstance { instSrcLoc = sloc,+ instDerived = False,+ instHead = cntxt :=> IsIn className convertedArgType,+ instAssocs = assocs }] | otherwise = failSl sloc $ "hsInstDeclToInst: kind error, attempt to make\n" ++ show convertedArgType ++ " (with kind " ++ show argTypeKind ++ ")\n" ++ "an instance of class " ++ show className ++@@ -297,7 +282,7 @@ -- the types will only ever be constructors or vars convType :: [(HsType, Kind)] -> Type-convType tsks = foldl1 TAp (map toType tsks)+convType tsks = foldl1 tAp (map toType tsks) toType :: (HsType, Kind) -> Type toType (HsTyCon n, k) = TCon $ Tycon (toName TypeConstructor n) k@@ -307,19 +292,31 @@ -} -+vtrace s v | verbose = trace s v+vtrace s v | otherwise = v qtToClassHead :: KindEnv -> HsQualType -> ([Pred],(Name,[Type]))-qtToClassHead kt (HsQualType cntx (HsTyApp (HsTyCon className) ty)) = (map (hsAsstToPred kt) cntx,(toName ClassName className,[runIdentity $ hsTypeToType kt ty]))+qtToClassHead kt qt@(HsQualType cntx (HsTyApp (HsTyCon className) ty)) =+ vtrace ("qtToClassHead" <+> show qt) $+ let res = (map (hsAsstToPred kt) cntx,+ (toName ClassName className,+ [runIdentity $ hsTypeToType (kiHsQualType kt (HsQualType cntx (HsTyTuple []))) ty]))+ in vtrace ("=" <+> show res) res -createClassAssocs kt decls = [ (ctc n,map ct as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where++createClassAssocs kt decls = + [ (ctc n,map ct as,ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ]+ where ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt) ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt) ctype HsTyAssoc = Nothing ctype t = Just $ runIdentity $ hsTypeToType kt t -createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where+createInstAssocs kt decls =+ [ (ctc n,map ct (czas ca),map ct as,ctype t)+ | HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] + where ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt) ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt) czas ca = let (HsTyCon {},zas) = fromHsTypeApp ca in zas@@ -331,9 +328,22 @@ f t rs = (t,rs) instanceToTopDecls :: KindEnv -> ClassHierarchy -> HsDecl -> (([HsDecl],[Assump]))-instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) (HsInstDecl _ qualType methods)- = unzip $ map (methodToTopDecls ch kt [] crecord qualType) $ methodGroups where- methodGroups = groupEquations methods+instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) (HsInstDecl sl qualType methods)+ = first concat . unzip . map (methodToTopDecls ch kt [] crecord qualType) $ methodGroups where++ missingMethodNames = map fst methodSigs \\ map getDeclName (filter (not . isHsTypeSig) methods)+ missingMethods+ = [ HsPatBind sl (HsPVar (nameName methodName))+ (HsUnGuardedRhs + (case lookup methodName (classDefaults crecord) of+ Just name -> HsVar (nameName name)+ Nothing -> HsError sl HsErrorSource ("missing method: "++show methodName)))+ []+ | methodName <- missingMethodNames+ ]+ methods' = methods ++ missingMethods+ methodGroups = groupEquations methods'+ methodSigs = classAssumps crecord (_,(className,_)) = qtToClassHead kt qualType crecord = case Map.lookup className classHierarchy of Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"@@ -341,22 +351,14 @@ tsubst na vv v = applyTyvarMap [(na,vv)] v instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) (HsClassDecl _ qualType methods)- = unzip $ map (defaultMethodToTopDecls kt methodSigs qualType) $ methodGroups where+ = unzip . map (defaultMethodToTopDecls kt methodSigs qualType) $ methodGroups where HsQualType _ (HsTyApp (HsTyCon className) _) = qualType methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) methods) methodSigs = case Map.lookup (toName ClassName className) classHierarchy of- Nothing -> error $ "defaultInstanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy"+ Nothing -> error $ "defaultInstanceToTopDecls: could not find class " ++ show className+ ++ "in class hierarchy" Just sigs -> classAssumps sigs -instanceToTopDecls kt ch@(ClassHierarchy classHierarchy) cad@(HsClassAliasDecl {})- = unzip $ map (aliasDefaultMethodToTopDecls kt methodSigs aliasName) $ methodGroups where- aliasName = toName ClassName (hsDeclName cad)- methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) (hsDeclDecls cad))- methodSigs = case Map.lookup aliasName classHierarchy of- Nothing -> error $ "aliasDefaultInstanceToTopDecls: could not find class "- ++ show aliasName ++ "in class hierarchy"- Just sigs -> concatMap (classAssumps . findClassRecord ch) (classClasses sigs)- instanceToTopDecls _ _ _ = mempty @@ -364,9 +366,8 @@ instanceName n t = toName Val $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ "." ++ show t) defaultInstanceName n = toName Val $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ ".default")-aliasDefaultInstanceName :: Name -> Class -> Name-aliasDefaultInstanceName n ca = toName Val $ Qual (Module "Instance@") $ HsIdent ('i':show n ++ ".default."++show ca) + methodToTopDecls :: ClassHierarchy -> KindEnv -- ^ the kindenv@@ -374,11 +375,7 @@ -> ClassRecord -- ^ the class we are lifting methods from -> HsQualType -> (Name, HsDecl)- -> (HsDecl,Assump)--methodToTopDecls ch kt preds crecord@(ClassAliasRecord {}) qt meth@(methodName, methodDecls) - = methodToTopDecls ch kt preds (findClassRecord ch cls) qt meth- where Just cls = Map.lookup methodName (classMethodMap crecord)+ -> ([HsDecl],Assump) methodToTopDecls _ kt preds crecord qt (methodName, methodDecls) = (renamedMethodDecls,(newMethodName, instantiatedSig)) where@@ -389,7 +386,18 @@ _ -> error $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord)) ++ " " ++ show methodName instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType- renamedMethodDecls = renameOneDecl newMethodName methodDecls+ renamedMethodDecls = [renameOneDecl newMethodName methodDecls,+ HsPragmaRules [HsRule {+ hsRuleSrcLoc = srcLoc methodDecls,+ hsRuleIsMeta = False,+ hsRuleIsMethod = True,+ hsRuleString = show newMethodName,+ hsRuleFreeVars = [],+ hsRuleLeftExpr = HsVar (nameName methodName),+ hsRuleRightExpr = HsVar (nameName newMethodName)+ }]+ ]+ defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsQualType -> (Name, HsDecl) -> (HsDecl,Assump) @@ -403,16 +411,6 @@ -- = newMethodSig cntxt newMethodName sigFromClass argType renamedMethodDecls = renameOneDecl newMethodName methodDecls -aliasDefaultMethodToTopDecls :: KindEnv -> [Assump] -> Class -> (Name, HsDecl) -> (HsDecl,Assump)-aliasDefaultMethodToTopDecls kt methodSigs aliasName (methodName, methodDecls)- = (renamedMethodDecls,(newMethodName,sigFromClass)) where- newMethodName = aliasDefaultInstanceName methodName aliasName- sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of- [x] -> x- _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show methodName- -- = newMethodSig cntxt newMethodName sigFromClass argType- renamedMethodDecls = renameOneDecl newMethodName methodDecls- renameOneDecl :: Name -> HsDecl -> HsDecl renameOneDecl newName (HsFunBind matches) = HsFunBind (map (renameOneMatch newName) matches)@@ -465,34 +463,10 @@ -------------------------------------------------------------------------------- -scatterAliasInstances :: ClassHierarchy -> ClassHierarchy-scatterAliasInstances ch =- let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch]- --ch `seq` liftIO $ putStrLn ("scatterAliasInstances: " ++ show cas)- instances = concatMap scatterInstancesOf cas- ret = foldr (modifyClassRecord $ \cr -> cr - { classInsts = [],- classMethodMap = Map.fromList [(meth, cls) | cls <- classClasses cr,- (meth,_) <- classAssumps (findClassRecord ch cls)]- })- (ch `mappend` classHierarchyFromRecords instances)- (map className cas)- -- liftIO $ mapM_ print (classRecords ret)- in ret- -scatterInstancesOf :: ClassRecord -> [ClassRecord]-scatterInstancesOf cr = map extract (classClasses cr)- where- extract c =- (newClassRecord c) { classInsts = - [Inst sl d ((cxt ++ [IsIn c2 xs | c2 <- classClasses cr, c2 /= c]) :=> IsIn c xs) []- | Inst sl d (cxt :=> IsIn _ xs) [] <- classInsts cr] }----------------------------------------------------------------------------------- failSl sl m = fail $ show sl ++ ": " ++ m -classHierarchyFromRecords rs = ClassHierarchy $ Map.fromListWith combineClassRecords [ (className x,x)| x <- rs ]+classHierarchyFromRecords rs+ = ClassHierarchy $ Map.fromListWith combineClassRecords [ (className x,x)| x <- rs ] -- I love tying el knot. makeClassHierarchy :: ClassHierarchy -> KindEnv -> [HsDecl] -> ClassHierarchy@@ -500,27 +474,30 @@ ans = Map.fromListWith combineClassRecords [ (className x,x)| x <- execWriter (mapM_ f ds) ] f (HsClassDecl sl t decls) | HsTyApp (HsTyCon className) (HsTyVar argName) <- tbody = do- let qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)+ let qualifiedMethodAssumps+ = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls) newClassContext = [HsAsst className [argName]] -- hsContextToContext [(className, argName)]- tell [ClassRecord { classArgs = classArgs, classAssocs = classAssocs, className = toName ClassName className, classSrcLoc = sl, classSupers = [ toName ClassName x | HsAsst x _ <- cntxt], classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- primitiveInsts, nameName n == className], classAssumps = qualifiedMethodAssumps }]+ tell [ClassRecord { classArgs = classArgs,+ classAssocs = classAssocs,+ className = toName ClassName className,+ classSrcLoc = sl,+ classSupers = [ toName ClassName x | HsAsst x _ <- cntxt],+ classInsts = [],+ classDefaults = [ (methodName, defaultInstanceName methodName)+ | decl <- decls, isHsPatBind decl || isHsFunBind decl,+ let methodName = getDeclName decl+ ],+ classAssumps = qualifiedMethodAssumps }] | otherwise = failSl sl "Invalid Class declaration." where HsQualType cntxt tbody = t classAssocs = createClassAssocs kt decls (_,(_,classArgs')) = qtToClassHead kt t classArgs = [ v | ~(TVar v) <- classArgs' ]- f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do- tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl),- classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)],- classSrcLoc = hsDeclSrcLoc decl,- classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)],- classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)],- classInsts = [],- classMethodMap = Map.empty- }] f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do- crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $ \ (x,inst) -> case Map.lookup x ch of+ crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $+ \ (x,inst) -> case Map.lookup x ch of Just cr -> ensureNotDup (srcLoc decl) inst (classInsts cr) >> return [cr { classInsts = mempty }] Nothing -> return [] -- case Map.lookup x ans of -- Just _ -> return []
src/FrontEnd/DataConsAssump.hs view
@@ -52,7 +52,7 @@ where typeName' = toName TypeConstructor typeName typeKind = kindOf typeName' kt- resultType = foldl TAp tycon argVars+ resultType = foldl tAp tycon argVars tycon = TCon (Tycon typeName' typeKind) argVars = map fromHsNameToTyVar $ zip argKinds args argKinds = init $ unfoldKind typeKind@@ -66,7 +66,7 @@ where typeName' = toName TypeConstructor typeName typeKind = kindOf typeName' kt- resultType = foldl TAp tycon argVars+ resultType = foldl tAp tycon argVars tycon = TCon (Tycon typeName' typeKind) argVars = map fromHsNameToTyVar $ zip argKinds args argKinds = init $ unfoldKind typeKind
src/FrontEnd/DeclsDepends.hs view
@@ -36,21 +36,21 @@ getDeclDeps :: HsDecl -> [HsName] -getDeclDeps (HsPatBind _pat _ rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)+getDeclDeps (HsPatBind _pat _ rhs wheres) = getRhsDeps rhs ++ concatMap getLocalDeclDeps wheres getDeclDeps (HsActionDecl _ _ e) = getExpDeps e-getDeclDeps (HsFunBind matches) = foldr (++) [] (map getMatchDeps matches)+getDeclDeps (HsFunBind matches) = concatMap getMatchDeps matches getDeclDeps _ = [] getMatchDeps :: HsMatch -> [HsName]-getMatchDeps (HsMatch _sloc _name _pats rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)+getMatchDeps (HsMatch _sloc _name _pats rhs wheres) = getRhsDeps rhs ++ concatMap getLocalDeclDeps wheres -- get the dependencies from the local definitions in a function getLocalDeclDeps :: HsDecl -> [HsName]-getLocalDeclDeps (HsFunBind matches) = foldr (++) [] (map getMatchDeps matches)+getLocalDeclDeps (HsFunBind matches) = concatMap getMatchDeps matches -getLocalDeclDeps (HsPatBind _sloc _hspat rhs wheres) = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)+getLocalDeclDeps (HsPatBind _sloc _hspat rhs wheres) = getRhsDeps rhs ++ concatMap getLocalDeclDeps wheres getLocalDeclDeps (HsActionDecl _sloc _ e) = getExpDeps e getLocalDeclDeps _ = []@@ -59,7 +59,7 @@ getRhsDeps :: HsRhs -> [HsName] getRhsDeps (HsUnGuardedRhs e) = getExpDeps e-getRhsDeps (HsGuardedRhss rhss) = foldr (++) [] (map getGuardedRhsDeps rhss)+getRhsDeps (HsGuardedRhss rhss) = concatMap getGuardedRhsDeps rhss getGuardedRhsDeps :: HsGuardedRhs -> [HsName] getGuardedRhsDeps (HsGuardedRhs _sloc guardExp rhsExp)@@ -73,27 +73,27 @@ expDeps (HsVar name) = tell [name] expDeps (HsLet decls e) = do expDeps e- tell $ foldr (++) [] (map getLocalDeclDeps decls)+ tell $ concatMap getLocalDeclDeps decls expDeps (HsCase e alts) = do expDeps e- tell $ foldr (++) [] (map getAltDeps alts)+ tell $ concatMap getAltDeps alts expDeps (HsDo stmts) = do- tell $ foldr (++) [] (map getStmtDeps stmts)+ tell $ concatMap getStmtDeps stmts expDeps (HsListComp e stmts) = do expDeps e- tell $ foldr (++) [] (map getStmtDeps stmts)+ tell $ concatMap getStmtDeps stmts expDeps e = traverseHsExp_ expDeps e getAltDeps :: HsAlt -> [HsName] getAltDeps (HsAlt _sloc _pat guardedAlts wheres) = getGuardedAltsDeps guardedAlts ++- foldr (++) [] (map getLocalDeclDeps wheres)+ concatMap getLocalDeclDeps wheres getGuardedAltsDeps :: HsRhs -> [HsName] getGuardedAltsDeps (HsUnGuardedRhs e) = getExpDeps e -getGuardedAltsDeps (HsGuardedRhss gAlts) = foldr (++) [] (map getGAltsDeps gAlts)+getGuardedAltsDeps (HsGuardedRhss gAlts) = concatMap getGAltsDeps gAlts getGAltsDeps :: HsGuardedRhs -> [HsName] getGAltsDeps (HsGuardedRhs _sloc e1 e2)@@ -106,4 +106,4 @@ getStmtDeps (HsQualifier e) = getExpDeps e getStmtDeps (HsLetStmt decls)- = foldr (++) [] (map getLocalDeclDeps decls)+ = concatMap getLocalDeclDeps decls
src/FrontEnd/HsParser.y view
@@ -329,7 +329,8 @@ rule :: { HsRule } : srcloc STRING mfreevars exp '=' exp { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6- , hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" } }+ , hsRuleIsMeta = error "hsRuleIsMeta not set"+ , hsRuleIsMethod = False } } rules :: { [HsRule] } : rules optsemi rule { $3 : $1 }
src/FrontEnd/HsSyn.hs view
@@ -265,9 +265,9 @@ srcLoc x = hsModuleSrcLoc x data HsRule = HsRule {- hsRuleUniq :: (Module,Int), hsRuleSrcLoc :: SrcLoc, hsRuleIsMeta :: Bool,+ hsRuleIsMethod :: Bool, -- for rules generated by FrontEnd.Class hsRuleString :: String, hsRuleFreeVars :: [(HsName,Maybe HsType)], hsRuleLeftExpr :: HsExp,
src/FrontEnd/Infix.hs view
@@ -24,7 +24,6 @@ import Util.HasSize import FrontEnd.HsSyn-import Support.MapBinaryInstance import Name.Name ----------------------------------------------------------------------------@@ -36,8 +35,8 @@ deriving(Monoid,HasSize) instance Binary FixityMap where- put (FixityMap ts) = putMap ts- get = fmap FixityMap getMap+ put (FixityMap ts) = put ts+ get = fmap FixityMap get restrictFixityMap :: (Name -> Bool) -> FixityMap -> FixityMap restrictFixityMap f (FixityMap fm) = FixityMap (Map.filterWithKey (\k _ -> f k) fm)
src/FrontEnd/KindInfer.hs view
@@ -9,6 +9,7 @@ KindEnv(), hsQualTypeToSigma, hsAsstToPred,+ kiHsQualType, kindOfClass, kindOf, restrictKindEnv,@@ -40,7 +41,6 @@ import GenUtil import Support.FreeVars import FrontEnd.HsSyn-import Support.MapBinaryInstance import Name.Name import qualified Util.Seq as Seq import qualified FlagDump as FD@@ -57,11 +57,11 @@ $(derive makeMonoid ''KindEnv) instance Binary KindEnv where- put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } = putMap a >> putMap b >> putMap c+ put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } = put a >> put b >> put c get = do- a <- getMap- b <- getMap- c <- getMap+ a <- get+ b <- get+ c <- get return KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } instance HasSize KindEnv where@@ -177,7 +177,7 @@ constrain KindAny k = return () constrain KindStar (KBase Star) = return () constrain KindQuest k@KBase {} = kindCombine kindFunRet k >> return ()-constrain KindQuestQuest (KBase KQuest) = fail "cannot constraint ? to be ??"+constrain KindQuestQuest (KBase KQuest) = fail "cannot constrain ? to be ??" constrain KindQuestQuest k@KBase {} = kindCombine kindArg k >> return () constrain KindSimple (KBase Star) = return () constrain KindSimple (a `Kfun` b) = do@@ -431,7 +431,7 @@ kindOf :: Name -> KindEnv -> Kind kindOf name KindEnv { kindEnv = env } = case Map.lookup name env of- Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar+-- Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar Just k -> k _ -> error $ "kindOf: could not find kind of : " ++ show (nameType name,name) @@ -461,7 +461,7 @@ aHsTypeToType kt HsTyExpKind { hsTyType = t } = aHsTypeToType kt t aHsTypeToType kt tuple@(HsTyTuple types) = tTTuple $ map (aHsTypeToType kt) types aHsTypeToType kt tuple@(HsTyUnboxedTuple types) = tTTuple' $ map (aHsTypeToType kt) types-aHsTypeToType kt (HsTyApp t1 t2) = TAp (aHsTypeToType kt t1) (aHsTypeToType kt t2)+aHsTypeToType kt (HsTyApp t1 t2) = tAp (aHsTypeToType kt t1) (aHsTypeToType kt t2) -- variables, we must know the kind of the variable here!@@ -494,15 +494,23 @@ -- = IsIn className (TVar $ Tyvar varName (kindOf varName kt)) | isConstructorLike (hsIdentString . hsNameIdent $ varName) = IsIn (toName ClassName className) (TCon (Tycon (toName TypeConstructor varName) (head $ kindOfClass (toName ClassName className) kt))) | otherwise = IsIn (toName ClassName className) (TVar $ tyvar (toName TypeVal varName) (head $ kindOfClass (toName ClassName className) kt))-hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType kt t1) (runIdentity $ hsTypeToType kt t2)+hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType' kt t1) (runIdentity $ hsTypeToType' kt t2) hsQualTypeToSigma kt qualType = hsQualTypeToType kt (Just []) qualType hsTypeToType :: Monad m => KindEnv -> HsType -> m Type-hsTypeToType kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t)+hsTypeToType kt t = return $ unsafePerformIO $ runKI kt $+ do kv <- newKindVar KindAny+ kiType (KVar kv) t+ kt' <- postProcess =<< getEnv+ hsTypeToType' kt' t ++hsTypeToType' :: Monad m => KindEnv -> HsType -> m Type+hsTypeToType' kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t)+ hsQualTypeToType :: Monad m => KindEnv -- ^ the kind environment -> Maybe [HsName] -- ^ universally quantify free variables excepting those in list.@@ -511,7 +519,7 @@ hsQualTypeToType kindEnv qs qualType = return $ hoistType $ tForAll quantOver ( ps' :=> t') where newEnv = kiHsQualType kindEnv qualType --newEnv = kindEnv- Just t' = hsTypeToType newEnv (hsQualTypeType qualType)+ Just t' = hsTypeToType' newEnv (hsQualTypeType qualType) ps = hsQualTypeHsContext qualType ps' = map (hsAsstToPred newEnv) ps quantOver = nub $ freeVars ps' ++ fvs
src/FrontEnd/Rename.hs view
@@ -295,9 +295,7 @@ fvs' <- sequence [ liftM2 (,) (rename x) (withSubTable subTable'' $ rename y)| (x,y) <- fvs] e1' <- rename e1 e2' <- rename e2- m <- getCurrentModule- i <- newUniq- return prules { hsRuleUniq = (m,i), hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' }+ return prules { hsRuleFreeVars = fvs', hsRuleLeftExpr = e1', hsRuleRightExpr = e2' } doesClassMakeSense :: HsQualType -> RM () doesClassMakeSense (HsQualType _ type_) = case type_ of
src/FrontEnd/Representation.hs view
@@ -27,10 +27,13 @@ fromTAp, fromTArrow, tassocToAp,+ splitTAp_maybe, MetaVar(..), tTTuple, tTTuple',- tList+ tList,+ tArrow,+ tAp )where import Data.DeriveTH@@ -94,6 +97,8 @@ tList = TCon (Tycon tc_List (Kfun kindStar kindStar)) +tArrow = TCon (Tycon tc_Arrow (kindArg `Kfun` kindFunRet `Kfun` kindStar))+ instance Eq Type where (TVar a) == (TVar b) = a == b (TMetaVar a) == (TMetaVar b) = a == b@@ -102,8 +107,11 @@ (TArrow a' a) == (TArrow b' b) = a' == b' && b == a _ == _ = False -tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl TAp (TCon con) (cas ++ eas)+tAp (TAp c@TCon{} a) b | c == tArrow = TArrow a b+tAp a b = TAp a b +tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl tAp (TCon con) (cas ++ eas)+ -- Unquantified type variables data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName :: !Name, tyvarKind :: Kind }@@ -311,12 +319,17 @@ fromTAp t = f t [] where f (TAp a b) rs = f a (b:rs)+ f (TArrow a b) rs = f (tAp tArrow a) (b:rs) f t rs = (t,rs) fromTArrow t = f t [] where f (TArrow a b) rs = f b (a:rs) f t rs = (reverse rs,t) +splitTAp_maybe :: Type -> Maybe (Type, Type)+splitTAp_maybe (TAp a b) = Just (a, b)+splitTAp_maybe (TArrow a b) = Just (tAp tArrow a, b)+splitTAp_maybe t = Nothing instance CanType MetaVar Kind where getType mv = metaKind mv
src/FrontEnd/Tc/Kind.hs view
@@ -72,6 +72,8 @@ | KVar Kindvar -- variables aren't really allowed in haskell in kinds deriving(Eq, Ord) -- but we need them for kind inference +infixr `Kfun`+ KBase kb `isSubsumedBy` KBase kb' = isSubsumedBy2 kb kb' Kfun k1 k2 `isSubsumedBy` Kfun k1' k2' = isSubsumedBy k1 k1' && isSubsumedBy k2 k2' _ `isSubsumedBy` _ = False
src/FrontEnd/Tc/Main.hs view
@@ -260,6 +260,12 @@ localEnv env $ do s2' <- evalType s2' lamPoly ps e s2' (p':rs) -- TODO poly+ lam (p:ps) e t@(TAp (TAp (TMetaVar mv) s1') s2') rs = do+ boxyMatch (TMetaVar mv) tArrow+ (p',env) <- tcPat p s1'+ localEnv env $ do+ s2' <- evalType s2'+ lamPoly ps e s2' (p':rs) -- TODO poly lam [] e typ rs = do e' <- tcExpr e typ return (HsLambda sloc (reverse rs) e')@@ -628,7 +634,7 @@ tcPragmaDecl _ = return [] -tcRule prule@HsRule { hsRuleUniq = uniq, hsRuleFreeVars = vs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2, hsRuleSrcLoc = sloc } =+tcRule prule@HsRule { hsRuleFreeVars = vs, hsRuleLeftExpr = e1, hsRuleRightExpr = e2, hsRuleSrcLoc = sloc } = withContext (locMsg sloc "in the RULES pragma" $ hsRuleString prule) ans where ans = do vs' <- mapM dv vs@@ -651,7 +657,9 @@ ch <- getClassHierarchy rs1 <- return $ simplify ch rs1 rs2 <- return $ simplify ch rs2- assertEntailment rs1 rs2+ -- SamB 2009.01.12:+ -- This doesn't make any sense to me -- it seems to break stuff ...+ -- assertEntailment rs1 rs2 return prule { hsRuleLeftExpr = e1, hsRuleRightExpr = e2 } dv (n,Nothing) = do v <- newMetaVar Tau kindStar
src/FrontEnd/Tc/Module.hs view
@@ -153,7 +153,7 @@ let smallClassHierarchy = makeClassHierarchy importClassHierarchy kindInfo ds- let cHierarchyWithInstances = scatterAliasInstances $ smallClassHierarchy `mappend` importClassHierarchy+ let cHierarchyWithInstances = smallClassHierarchy `mappend` importClassHierarchy when (dump FD.ClassSummary) $ do putStrLn " ---- class summary ---- "@@ -193,7 +193,7 @@ when (dump FD.Sigenv) $ do {putStrLn " ---- initial sigEnv information ---- "; putStrLn $ render $ pprintEnvMap sigEnv}- let bindings = (funPatBinds ++ liftedInstances)+ let bindings = (funPatBinds ++ filter (not . isHsPragmaRules) liftedInstances) --classDefaults = snub [ getDeclName z | z <- cDefBinds, isHsFunBind z || isHsPatBind z ] classNoDefaults = snub (concat [ getDeclNames z | z <- cDefBinds ]) -- List.\\ classDefaults noDefaultSigs = Map.fromList [ (n,maybe (error $ "sigEnv:" ++ show n) id $ Map.lookup n sigEnv) | n <- classNoDefaults ]@@ -229,7 +229,7 @@ } (localVarEnv,checkedRules,coercions,tcDs) <- withOptionsT (modInfoOptions tms) $ runTc tcInfo $ do- (tcDs,out) <- listen (tiProgram program ds)+ (tcDs,out) <- listen (tiProgram program (ds ++ filter isHsPragmaRules liftedInstances)) env <- getCollectedEnv cc <- getCollectedCoerce let cc' = Map.union cc $ Map.fromList [ (as,lup v) | (as,v) <- outKnots out ]@@ -257,7 +257,11 @@ allExports = Set.fromList (concatMap modInfoExport ms) externalKindEnv = restrictKindEnv (\ x -> isGlobal x && (getModule x `elem` map (Just . modInfoName) ms)) kindInfo let hoBld = mempty {- hoAssumps = Map.filterWithKey (\k _ -> k `member` allExports) allAssumps,+ hoAssumps = Map.filterWithKey + (\k _ -> (k `member` allExports)+ || (k `elem` (map snd . concatMap classDefaults . classRecords $+ smallClassHierarchy)))+ allAssumps, hoFixities = restrictFixityMap (`member` allExports) thisFixityMap, -- TODO - this contains unexported names, we should filter these before writing to disk. hoKinds = externalKindEnv,
src/FrontEnd/Tc/Monad.hs view
@@ -254,8 +254,9 @@ nvs <- mapM newVar (replicate num kindArg) let nvs' = map TVar nvs return (TForAll nvs $ [] :=> foldr TArrow (tTTuple' nvs') nvs')- Nothing -> fail $ "Could not find var in tcEnv:" ++ show (nameType n,n)-+ Nothing -> fail $ "Could not find var in tcEnv:" <+> show (nameType n,n)+ <$> "env:" <+> pprint env+ newMetaVar :: MetaVarType -> Kind -> Tc Type newMetaVar t k = do@@ -269,7 +270,7 @@ inst:: Map.Map Int Type -> Map.Map Atom Type -> a -> a instance Instantiate Type where- inst mm ts (TAp l r) = TAp (inst mm ts l) (inst mm ts r)+ inst mm ts (TAp l r) = tAp (inst mm ts l) (inst mm ts r) inst mm ts (TArrow l r) = TArrow (inst mm ts l) (inst mm ts r) inst mm _ t@TCon {} = t inst mm ts (TVar tv ) = case Map.lookup (tyvarAtom tv) ts of@@ -365,7 +366,7 @@ tell [(t,b)] return b f e@TCon {} _ = return e- f (TAp a b) vs = liftM2 TAp (f a vs) (f b vs)+ f (TAp a b) vs = liftM2 tAp (f a vs) (f b vs) f (TArrow a b) vs = liftM2 TArrow (f a vs) (f b vs) f (TForAll as (ps :=> t)) vs = do t' <- f t (vs List.\\ as)
src/FrontEnd/Tc/Type.hs view
@@ -17,11 +17,14 @@ -- followTaus, fromTAp, fromTArrow,+ splitTAp_maybe, module FrontEnd.Tc.Type, prettyPrintType, -- readMetaVar, tForAll, tList,+ tArrow,+ tAp, -- Constraint(..), -- applyTyvarMap, Class(),@@ -259,7 +262,7 @@ tickleM f (IsEq t1 t2) = return IsEq `ap` f t1 `ap` f t2 instance Tickleable Type Type where- tickleM f (TAp l r) = return TAp `ap` f l `ap` f r+ tickleM f (TAp l r) = return tAp `ap` f l `ap` f r tickleM f (TArrow l r) = return TArrow `ap` f l `ap` f r tickleM f (TAssoc c cas eas) = return (TAssoc c) `ap` mapM f cas `ap` mapM f eas tickleM f (TForAll ta (ps :=> t)) = do
src/FrontEnd/Tc/Unify.hs view
@@ -166,7 +166,7 @@ bm a (TMetaVar mv) | (TCon ca,as) <- fromTAp a = do printRule $ "CEQ1: " ++ prettyPrintType a a <- occursCheck mv a- withMetaVars mv (map getType as) (\ ts -> foldl TAp (TCon ca) ts) $ \ ts ->+ withMetaVars mv (map getType as) (\ ts -> foldl tAp (TCon ca) ts) $ \ ts -> sequence_ [ boxyMatch a t | t <- ts | a <- as ] return False @@ -174,7 +174,7 @@ --printRule $ "CEQ1: " ++ pprint a let xxs = x:xs a <- occursCheck mv a- withMetaVars mv (map getType xxs) (\ (t:ts) -> foldl TAp t ts) $ \ ts ->+ withMetaVars mv (map getType xxs) (\ (t:ts) -> foldl tAp t ts) $ \ ts -> sequence_ [ boxyMatch a t | t <- ts | a <- xxs ] return False @@ -209,7 +209,7 @@ return False - bm (TAp a b) (TAp c d) = do+ bm t1 t2 | Just (a, b) <- splitTAp_maybe t1, Just (c, d) <- splitTAp_maybe t2 = do printRule "APP" a `boxyMatch` c b `boxyMatch` d
src/FrontEnd/TypeSynonyms.hs view
@@ -22,15 +22,14 @@ import Name.Name import Util.HasSize import FrontEnd.Warning-import Support.MapBinaryInstance newtype TypeSynonyms = TypeSynonyms (Map.Map Name ([HsName], HsType, SrcLoc)) deriving(Monoid,HasSize) instance Binary TypeSynonyms where- put (TypeSynonyms ts) = putMap ts- get = fmap TypeSynonyms getMap+ put (TypeSynonyms ts) = put ts+ get = fmap TypeSynonyms get restrictTypeSynonyms :: (Name -> Bool) -> TypeSynonyms -> TypeSynonyms restrictTypeSynonyms f (TypeSynonyms fm) = TypeSynonyms (Map.filterWithKey (\k _ -> f k) fm)
src/FrontEnd/TypeSyns.hs view
@@ -527,7 +527,7 @@ getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)] getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp) = zip (getNamesFromHsPat hsPat) (repeat srcLoc) getHsNamesAndASrcLocsFromHsStmt (HsQualifier _hsExp) = []-getHsNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concat $ map getHsNamesAndASrcLocsFromHsDecl hsDecls+getHsNamesAndASrcLocsFromHsStmt (HsLetStmt hsDecls) = concatMap getHsNamesAndASrcLocsFromHsDecl hsDecls -- the getNew... functions are used only inside class declarations to avoid _re_ renaming things@@ -539,8 +539,8 @@ getHsNamesFromHsType :: HsType -> [HsName] getHsNamesFromHsType (HsTyFun hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)-getHsNamesFromHsType (HsTyTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes-getHsNamesFromHsType (HsTyUnboxedTuple hsTypes) = concat $ map getHsNamesFromHsType hsTypes+getHsNamesFromHsType (HsTyTuple hsTypes) = concatMap getHsNamesFromHsType hsTypes+getHsNamesFromHsType (HsTyUnboxedTuple hsTypes) = concatMap getHsNamesFromHsType hsTypes getHsNamesFromHsType (HsTyApp hsType1 hsType2) = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2) getHsNamesFromHsType (HsTyVar hsName) = [hsName] getHsNamesFromHsType (HsTyForall vs qt) = getHsNamesFromHsQualType qt List.\\ map hsTyVarBindName vs
src/Grin/DeadCode.hs view
@@ -29,11 +29,11 @@ -> IO Grin -- ^ output deadCode stats roots grin = do fixer <- newFixer- usedFuncs <- newSupply fixer- usedArgs <- newSupply fixer- usedCafs <- newSupply fixer- pappFuncs <- newValue fixer bottom- suspFuncs <- newValue fixer bottom+ usedFuncs <- newSupply fixer :: IO (Supply Atom Bool)+ usedArgs <- newSupply fixer :: IO (Supply (Tag, Int) Bool)+ usedCafs <- newSupply fixer :: IO (Supply Var Bool)+ pappFuncs <- newValue fixer bottom :: IO (Value (Set.Set Tag))+ suspFuncs <- newValue fixer bottom :: IO (Value (Set.Set Tag)) -- set all roots as used flip mapM_ roots $ \r -> do addRule $ value True `implies` sValue usedFuncs r@@ -127,12 +127,6 @@ g (Store n) = addRule $ doNode n g (Fetch x) = addRule $ doNode x g Alloc { expValue = v, expCount = c, expRegion = r } = addRule $ doNode v `mappend` doNode c `mappend` doNode r-{- g Let { expDefs = defs, expBody = body } = do- mapM_ goAgain [ (name,bod) | FuncDef { funcDefBody = bod, funcDefName = name } <- defs]- flip mapM_ (map funcDefName defs) $ \n -> do- --n' <- supplyValue usedFuncs n- --addRule $ fn' `implies` n'- return ()-} g Error {} = return () -- TODO - handle function and case return values smartier. g (Return ns) = mapM_ (addRule . doNode) ns@@ -145,7 +139,7 @@ h (p,e) = g e doNode (NodeC n as) | not postInline, Just (x,fn) <- tagUnfunction n = let consts = (mconcatMap doConst as)- usedfn = implies fn' (sValue usedFuncs fn)+ usedfn = fn' `implies` sValue usedFuncs fn suspfn | x > 0 = conditionalRule id fn' (pappFuncs `isSuperSetOf` value (Set.singleton fn)) | otherwise = conditionalRule id fn' (suspFuncs `isSuperSetOf` value (Set.singleton fn)) in mappend consts $ mconcat (usedfn:suspfn:[ mconcatMap (implies (sValue usedArgs fn) . varValue) (freeVars a) | (fn,a) <- combineArgs fn as])
src/Grin/FromE.hs view
@@ -1,6 +1,7 @@-module Grin.FromE(compile) where+module Grin.FromE(compile,disambiguateProgram) where import Char+import Control.Monad.State import Control.Monad.Reader import Control.Monad.Trans import Data.Graph(stronglyConnComp, SCC(..))@@ -50,6 +51,8 @@ import qualified Info.Info as Info import qualified Stats +import E.Traverse+import qualified Data.Traversable as T {- | Tags@@ -98,7 +101,10 @@ counter :: IORef Int } -dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ fromAtom n <+> hsep (map show as) <+> "::" <+> show t <> f z <> g th| (n,TyTy { tySlots = as, tyReturn = t, tySiblings = z, tyThunk = th}) <- Map.toList tt] where+dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ fromAtom n <+> hsep (map show as) <+> "::" <+> show t <> f z <> g th+ | (n,TyTy { tySlots = as, tyReturn = t, tySiblings = z+ , tyThunk = th}) <- Map.toList tt]+ where f Nothing = mempty f (Just v) = text " " <> tshow v g TyNotThunk = mempty@@ -161,7 +167,62 @@ toTyTy (as,r) = tyTy { tySlots = as, tyReturn = r } +-- Remove all disambiguity due to name shadowing.+disambiguateProgram :: Program -> Program+disambiguateProgram prog+ = evalState (programMapBodies (fn Map.empty) prog) 1+ where fn subst (ELam tvr e)+ = do (old,new) <- rename tvr+ let newSubst = Map.insert old new subst+ liftM (ELam new) (fn newSubst e)+ fn subst (EPi tvr e)+ = do (old,new) <- rename tvr+ let newSubst = Map.insert old new subst+ liftM (EPi new) (fn newSubst e)+ fn subst (ELetRec defs body)+ = do nameSubst <- forM defs $ \(tvr,_) -> rename tvr+ let newSubst = Map.fromList nameSubst `Map.union` subst+ defs' <- forM defs $ \(tvr, e) -> fn newSubst e+ body' <- fn newSubst body+ return $ ELetRec (zip (map snd nameSubst) defs') body'+ fn subst ec@(ECase e t bind alts def fv)+ = do e' <- fn subst e+ (old,new) <- rename bind+ let subst' = Map.insert old new subst+ def' <- T.mapM (fn subst') def+ let alt (Alt lc@(LitCons{litArgs=args}) e)+ = do args' <- mapM rename args+ let newSubst = Map.fromList args' `Map.union` subst'+ e' <-fn newSubst e+ return $ Alt lc{litArgs = map snd args'} e'+ alt (Alt lit e) = do e' <- fn subst' e+ return $ Alt lit e'+ alts' <-mapM alt alts+ return $ caseUpdate $ ECase e' t new alts' def' fv+ fn subst (EVar tvr)+ = case Map.lookup tvr subst of+ Nothing -> return $ EVar tvr+ Just new -> return $ EVar new+ fn subst (ELit (LitCons name args ty alias))+ = do args' <- mapM (fn subst) args+ return $ ELit (LitCons name args' ty alias)+ fn subst e = emapE (fn subst) e+ genNewId :: State Int Id+ genNewId = do s <- get+ put (s+1)+ return (anonymous s)+ rename tvr | idIsNamed (tvrIdent tvr) = return (tvr,tvr)+ | otherwise = do new <- genNewId+ return (tvr, tvr{tvrIdent = new})+++++ {-# NOINLINE compile #-}+{-+ +-} compile :: Program -> IO Grin compile prog@Program { progDataTable = dataTable } = do let entries = progEntryPoints prog@@ -236,7 +297,8 @@ return grin where scMap = fromList [ (tvrIdent t,toEntry x) | x@(t,_,_) <- map combTriple $ progCombinators prog]- initTyEnv = mappend primTyEnv $ TyEnv $ Map.fromList $ concat [ makePartials (a,b,c) | (_,(a,b,c)) <- massocs scMap] ++ concat [con x| x <- Map.elems $ constructorMap dataTable, conType x /= eHash]+ initTyEnv = mappend primTyEnv $ TyEnv $ Map.fromList $ concat [ makePartials (a,b,c) | (_,(a,b,c)) <- massocs scMap] +++ concat [con x| x <- Map.elems $ constructorMap dataTable, conType x /= eHash] con c | (EPi (TVr { tvrType = a }) b,_) <- fromLam $ conExpr c = return $ (tagArrow,toTyTy ([tyDNode, tyDNode],[TyNode])) con c | keepCon = return $ (n,TyTy { tyThunk = TyNotThunk, tySlots = keepIts as, tyReturn = [TyNode], tySiblings = fmap (map convertName) sibs}) where n | sortKindLike (conType c) = convertName (conName c)@@ -306,7 +368,7 @@ conv :: E -> Val conv e | Just [v] <- literal e = v conv (ELit lc@LitCons { litName = n, litArgs = es }) | Just nn <- getName lc = (Const (NodeC nn (keepIts $ map conv es)))- conv (EPi (TVr { tvrIdent = 0, tvrType = a}) b) = Const $ NodeC tagArrow [conv a,conv b]+ conv (EPi (TVr { tvrIdent = i, tvrType = a}) b) | isEmptyId i = Const $ NodeC tagArrow [conv a,conv b] conv (EVar v) | v `Set.member` lbs = Var (cafNum v) (TyPtr TyNode) conv e | (EVar x,as) <- fromAp e, Just vs <- mlookup x res, vs > length as = Const (NodeC (partialTag (scTag x) (vs - length as)) (keepIts $ map conv as)) conv (EVar v) | Just ce <- mlookup v coMap = ce@@ -334,7 +396,7 @@ instance ToVal TVr where toVal TVr { tvrType = ty, tvrIdent = num } = case toType (TyPtr TyNode) ty of -- TyTup [] -> Tup []- ty -> Var (V num) ty+ ty -> Var (V (idToInt num)) ty doApply x y ty | not (keepIt y) = App funcApply [x] ty@@ -494,7 +556,7 @@ r <- ce r return $ e :>>= [] :-> r ce ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } | Just ty <- toCmmTy (getType e :: E) = do- v <- if tvrIdent b == 0 then newPrimVar $ TyPrim ty else return $ toVal b+ v <- if isEmptyId (tvrIdent b) then newPrimVar $ TyPrim ty else return $ toVal b e <- ce e as' <- mapM cp'' as def <- createDef d (return (toVal b))@@ -504,7 +566,7 @@ v <- newNodeVar e <- ce scrut case (b,scrut) of- (TVr { tvrIdent = 0 },EVar etvr) -> localEvaled [etvr] v $ do+ (TVr { tvrIdent = i },EVar etvr) | isEmptyId i -> localEvaled [etvr] v $ do as <- mapM cp as def <- createDef d newNodeVar return $ e :>>= [v] :-> Case v (as ++ def)@@ -512,7 +574,7 @@ as <- mapM cp as def <- createDef d newNodeVar return $ e :>>= [v] :-> Return [toVal etvr] :>>= [toVal b] :-> Case v (as ++ def)- (TVr { tvrIdent = 0 },_) -> do+ (TVr { tvrIdent = i },_) | isEmptyId i -> do as <- mapM cp as def <- createDef d newNodeVar return $ e :>>= [v] :-> Case v (as ++ def)@@ -527,7 +589,7 @@ ce e = error $ "ce: " ++ render (pprint (funcName,e)) localEvaled vs v action = local (\lenv -> lenv { evaledMap = nm `mappend` evaledMap lenv }) action where- nm = fromList [ (tvrIdent x, v) | x <- vs, tvrIdent x /= 0 ]+ nm = fromList [ (tvrIdent x, v) | x <- vs, not (isEmptyId (tvrIdent x)) ] localFuncs vs action = local (\lenv -> lenv { lfuncMap = fromList vs `mappend` lfuncMap lenv }) action @@ -689,7 +751,8 @@ -- runtime behavior is considered, it means a compile time constant, the -- CAFs may be updated with evaluated values. - constant :: Monad m => E -> m Val+-- constant :: Monad m => E -> m Val+ constant :: E -> Maybe Val constant (EVar tvr) | Just c <- mlookup (tvrIdent tvr) (ccafMap cenv) = return c | Just (v,as,_) <- mlookup (tvrIdent tvr) (scMap cenv) , t <- partialTag v (length as), tagIsWHNF t = if isLifted (EVar tvr) then return $ Const $ NodeC t [] else return (NodeC t [])@@ -698,12 +761,12 @@ constant e@(ELit lc@LitCons { litName = n, litArgs = es }) | Just es <- mapM constant es, Just nn <- getName lc = if isLifted e then return $ Const (NodeC nn (keepIts es)) else return (NodeC nn (keepIts es))- constant (EPi (TVr { tvrIdent = 0, tvrType = a}) b) | Just a <- constant a, Just b <- constant b = return $ NodeC tagArrow [a,b]+ constant (EPi (TVr { tvrIdent = i, tvrType = a}) b) | isEmptyId i, Just a <- constant a, Just b <- constant b = return $ NodeC tagArrow [a,b] constant _ = fail "not a constant term" -- | convert a constructor into a Val, arguments may depend on local vars. con :: Monad m => E -> m [Val]- con (EPi (TVr {tvrIdent = 0, tvrType = x}) y) = do+ con (EPi (TVr {tvrIdent = i, tvrType = x}) y) | isEmptyId i= do return $ [NodeC tagArrow (args [x,y])] con v@(ELit LitCons { litName = n, litArgs = es }) | conAlias cons /= NotAlias = error $ "Alias still exists: " ++ show v@@ -733,7 +796,7 @@ -- | converts an unboxed literal-literal :: Monad m => E -> m [Val]+literal :: E -> Maybe [Val] literal (ELit LitCons { litName = n, litArgs = xs }) | Just xs <- mapM literal xs, Just _ <- fromUnboxedNameTuple n = return (keepIts $ concat xs) literal (ELit (LitInt i ty)) | Just ptype <- toCmmTy ty = return $ [Lit i (TyPrim ptype)] literal (ELit (LitInt i (ELit (LitCons { litArgs = [], litAliasFor = Just af })))) = literal $ ELit (LitInt i af)
src/Grin/Grin.hs view
@@ -298,15 +298,16 @@ data Grin = Grin {- grinEntryPoints :: Map.Map Atom (FfiExport, ([ExtType], ExtType)),- grinPhase :: !Phase,- grinTypeEnv :: TyEnv,- grinFunctions :: [FuncDef],+ grinEntryPoints :: Map.Map Atom (FfiExport, ([ExtType], ExtType)),+ grinPhase :: !Phase,+ grinTypeEnv :: TyEnv,+ grinFunctions :: [FuncDef], grinSuspFunctions :: Set.Set Atom, grinPartFunctions :: Set.Set Atom,- grinStats :: !Stats.Stat,- grinCafs :: [(Var,Val)]-}+ grinStats :: !Stats.Stat,+ grinCafs :: [(Var,Val)],+ grinUnique :: Int+ } emptyGrin = Grin {@@ -317,8 +318,9 @@ grinSuspFunctions = mempty, grinPartFunctions = mempty, grinStats = mempty,- grinCafs = mempty-}+ grinCafs = mempty,+ grinUnique = 1+ } grinEntryPointNames = Map.keys . grinEntryPoints
src/Grin/Lint.hs view
@@ -50,10 +50,10 @@ hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""] hPrintGrin h grin hClose h- wdump FD.Grin $ do+ {-wdump FD.Grin $ do putErrLn $ "v-- " ++ pname ++ " Grin" printGrin grin- putErrLn $ "^-- " ++ pname ++ " Grin"+ putErrLn $ "^-- " ++ pname ++ " Grin"-} transformGrin :: TransformParms Grin -> Grin -> IO Grin
src/Grin/Show.hs view
@@ -36,7 +36,7 @@ -instance DocLike d => PPrint d Val where+instance PPrint Doc Val where pprint v = prettyVal v @@ -64,7 +64,7 @@ operator = bold . text keyword = bold . text-tag x = text x+tag = color "blue" . text func = color "lightgreen" . text prim = color "red" . text --func = text@@ -86,9 +86,9 @@ prettyExp vl (Return []) = vl <> keyword "return" <+> text "()" prettyExp vl (Return [v]) = vl <> keyword "return" <+> prettyVal v prettyExp vl (Return vs) = vl <> keyword "return" <+> tupled (map prettyVal vs)-prettyExp vl (Store v@Var {}) | getType v == tyDNode = vl <> keyword "demote" <+> prettyVal v+--prettyExp vl (Store v@Var {}) | getType v == tyDNode = vl <> keyword "demote" <+> prettyVal v prettyExp vl (Store v) = vl <> keyword "store" <+> prettyVal v-prettyExp vl (Fetch v@Var {}) | getType v == tyINode = vl <> keyword "promote" <+> prettyVal v+--prettyExp vl (Fetch v@Var {}) | getType v == tyINode = vl <> keyword "promote" <+> prettyVal v prettyExp vl (Fetch v) = vl <> keyword "fetch" <+> prettyVal v prettyExp vl (Error "" _) = vl <> prim "exitFailure" prettyExp vl (Error s _) = vl <> keyword "error" <+> tshow s@@ -122,7 +122,7 @@ prettyExp vl Call { expValue = ValPrim ap [] (TyCall Primitive' _ _), expArgs = vs } = vl <> prim (tshow ap) <+> hsep (map prettyVal vs) {-# NOINLINE prettyVal #-}-prettyVal :: DocLike d => Val -> d+prettyVal :: Val -> Doc prettyVal s | Just [] <- valToList s = text "[]" prettyVal s | Just st <- fromVal s = text $ show (st::String) prettyVal s | Just vs <- valToList s = list $ map prettyVal vs
src/Ho/Binary.hs view
@@ -5,8 +5,7 @@ import Data.Binary import Ho.Type-import Support.MapBinaryInstance-import Name.Binary()+--import Name.Binary() instance Binary HoHeader where@@ -24,7 +23,7 @@ instance Binary HoBuild where put (HoBuild ae af ag ah ai ak al am) = do- putMap ae+ put ae put af put ag put ah@@ -33,7 +32,7 @@ put al put am get = do- ae <- getMap+ ae <- get af <- get ag <- get ah <- get@@ -47,9 +46,9 @@ instance Binary HoExp where put (HoExp ac ad) = do put ac- putMap ad+ put ad get = do ac <- get- ad <- getMap+ ad <- get return (HoExp ac ad)
src/Ho/Build.hs view
@@ -60,11 +60,13 @@ import Util.Gen hiding(putErrLn,putErr,putErrDie) import Util.SetLike import LHCVersion+import Data.GraphViz as GV import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified FlagDump as FD import qualified FlagOpts as FO import qualified Util.Graph as G+import qualified Data.Graph.Inductive as GI import qualified Data.Digest.Pure.MD5 as MD5 import qualified Codec.Binary.UTF8.String as UTF8 import System.FilePath (takeExtension)@@ -273,9 +275,35 @@ toCompUnitGraph :: Done -> [Module] -> IO CompUnitGraph toCompUnitGraph done roots = do let fs m = maybe (error $ "can't find deps for: " ++ show m) snd (Map.lookup m (knownSourceMap done))+ gr :: G.Graph ((Module, SourceHash), [Module]) Module gr = G.newGraph [ ((m,sourceHash sc),fs (sourceHash sc)) | (m,Found sc) <- Map.toList (modEncountered done)] (fst . fst) snd gr' = G.sccGroups gr- lmods = Map.mapMaybe ( \ x -> case x of ModLibrary _ h -> Just h ; _ -> Nothing) (modEncountered done)+ + -- Note: tred(1) is VERY handy with these graphs!+ when (dump FD.DepGraph) $ do+ let nodes = zip [0..] [(m,sourceHash sc) | (m,Found sc) <- (Map.toList (modEncountered done))]+ nodeMap = Map.fromList [ (sh, n) | (n,(sh,_)) <- nodes ]+ gri :: GI.Gr (Module, SourceHash) ()+ gri = GI.mkGraph nodes [ (n,n2,())+ | (n,(_,sh)) <- nodes,+ n2 <- concatMap (maybeToList . (`Map.lookup` nodeMap)) (fs sh)+ ]+ + sccMap = Map.fromList [(n, ns) | ns <- (map.map) (fst.fst) gr', n <- ns]++ cluster ln@(_,(m,_)) = case (fromJust $ Map.lookup m sccMap) of+ [_] -> N ln+ ms -> C ms (N ln)++ fcluster _ = [Style Dashed]++ fnode (_,(m,_)) = [Label (show m)]+ fedge _ = []++ writeFile "deps.dot" (show $ clusterGraphToDot gri [GV.Unknown "aspect" "2,10"]+ cluster fcluster fnode fedge)++ let lmods = Map.mapMaybe ( \ x -> case x of ModLibrary _ h -> Just h ; _ -> Nothing) (modEncountered done) phomap = Map.fromListWith (++) (concat [ [ (m,[hh]) | (m,_) <- hohDepends hoh ] | (hh,(_,hoh,_)) <- Map.toList (hosEncountered done)]) sources = Map.fromList [ (m,sourceHash sc) | (m,Found sc) <- Map.toList (modEncountered done)] when (dump FD.SccModules) $ do
src/Ho/Type.hs view
@@ -15,7 +15,6 @@ import FrontEnd.SrcLoc(SrcLoc) import FrontEnd.Tc.Type(Type()) import FrontEnd.HsSyn(Module)-import Support.MapBinaryInstance() import Name.Id import Name.Name(Name) import FrontEnd.TypeSynonyms(TypeSynonyms)
src/LHCVersion.hs view
@@ -6,7 +6,7 @@ import qualified Paths_lhc as P package = "lhc"-tag = "zhu"+tag = "scio" version = showVersion P.version shortVersion = concat $ intersperse "." $ map show $ take 3 $ versionBranch P.version
src/Main.hs view
@@ -105,7 +105,7 @@ catom action = action `finally` dumpToFile -main = do -- runMain $ catom $ bracketHtml $ do+main = runMain $ do o <- processOptions progressM $ do (argstring,_) <- getArgString@@ -188,7 +188,7 @@ f rs = List.union rs [ x | x <- nrules, ruleHead x == combHead comb] let finalVarMap = mappend (fromList [(tvrIdent tvr,Just $ EVar tvr) | tvr <- map combHead $ melems choCombs ]) (choVarMap accumho)- choCombs = mfilterWithKey (\k _ -> k /= emptyId) choCombinators'+ choCombs = mfilterWithKey (\k _ -> not (isEmptyId k)) choCombinators' (mod:_) = Map.keys $ hoExports $ hoExp aho return $ mempty { choVarMap = finalVarMap,@@ -246,9 +246,14 @@ let ds = [ (v,e) | (v,e) <- classInstances ] ++ [ (v,lc) | (n,v,lc) <- ds', v `notElem` fsts classInstances ] -- sequence_ [lintCheckE onerrNone fullDataTable v e | (_,v,e) <- ds ] - -- Build rules from instances, specializations, and user specified rules and catalysts++{- SamB 2008.01.09: doing this in E.FromHS is error prone!+ -- Build rules from instances let instanceRules = createInstanceRules fullDataTable (hoClassHierarchy $ hoBuild ho') (ds `mappend` hoEs (hoBuild ho))- -- FIXME: 'converRules' and 'procAllSpecs' use IO for error handling. Use an error monad if they are user errors+-}++ -- Build rules from specializations and user specified rules and catalysts+ -- FIXME: 'convertRules' and 'procAllSpecs' use IO for error handling. Use an error monad if they are user errors -- otherwise use exceptions and make the calls pure. userRules <- convertRules (progModule prog) tiData (hoClassHierarchy $ hoBuild ho') allAssumps fullDataTable decls (nds,specializeRules) <- procAllSpecs (tiCheckedRules tiData) ds@@ -265,7 +270,8 @@ wdump FD.CoreInitial $ mapM_ (\(v,lc) -> printCheckName'' fullDataTable v lc) ds - let rules@(Rules rules') = instanceRules `mappend` userRules `mappend` specializeRules+ let rules@(Rules rules') = -- instanceRules `mappend`+ userRules `mappend` specializeRules wdump FD.Rules $ putStrLn " ---- user rules ---- " >> printRules RuleUser rules wdump FD.Rules $ putStrLn " ---- user catalysts ---- " >> printRules RuleCatalyst rules@@ -495,6 +501,7 @@ rules' = Rules $ fromList [ (combIdent x,combRules x) | x <- melems (choCombinators cho), not $ null (combRules x) ] -- dump final version of various requested things+ wdump FD.Progress $ putStrLn " --- final versions --- " wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable) when (dump FD.ClassSummary) $ do putStrLn " ---- class summary ---- "@@ -531,7 +538,7 @@ targetIndex = 0 prog <- return $ runIdentity $ flip programMapDs prog $ \(t,e) -> return $ if tvrIdent t == toId v_target then (t { tvrInfo = setProperty prop_INLINE mempty },theTarget) else (t,e) - --wdump FD.Core $ printProgram prog+ wdump FD.Core $ (progress "Before typeAnalyze:" >> printProgram prog) prog <- if (fopts FO.TypeAnalysis) then do typeAnalyze False prog else return prog when (verbose) $ do putStrLn "Type analyzed methods" flip mapM_ (programDs prog) $ \ (t,e) -> do@@ -540,7 +547,7 @@ 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+ wdump FD.Core $ (progress "Before expanding method placeholders:" >> printProgram prog) cmethods <- do let es' = concatMap expandPlaceholder (progCombinators prog)@@ -647,7 +654,6 @@ -- FIXME: do this better unless (isOptMode GenerateHo || isOptMode GenerateHoGrin) $ rm [n++".ho"]- unless (isOptMode GenerateHoGrin) $ rm [n ++ "_final.grin"] unless (isOptMode GenerateC) $ rm [n ++ "_code.c"] -- | this gets rid of all type variables, replacing them with boxes that can hold any type@@ -680,9 +686,9 @@ -- | get rid of unused bindings cleanupE :: E -> E cleanupE e = runIdentity (f e) where- f (ELam t@TVr { tvrIdent = v } e) | v /= 0, v `notMember` freeIds e = f (ELam t { tvrIdent = 0 } e)- f (EPi t@TVr { tvrIdent = v } e) | v /= 0, v `notMember` freeIds e = f (EPi t { tvrIdent = 0 } e)- f ec@ECase { eCaseBind = t@TVr { tvrIdent = v } } | v /= 0, v `notMember` (freeVars (caseBodies ec)::IdSet) = f ec { eCaseBind = t { tvrIdent = 0 } }+ f (ELam t@TVr { tvrIdent = v } e) | not (isEmptyId v), v `notMember` freeIds e = f (ELam t { tvrIdent = emptyId } e)+ f (EPi t@TVr { tvrIdent = v } e) | not (isEmptyId v), v `notMember` freeIds e = f (EPi t { tvrIdent = emptyId } e)+ f ec@ECase { eCaseBind = t@TVr { tvrIdent = v } } | not (isEmptyId v), v `notMember` (freeVars (caseBodies ec)::IdSet) = f ec { eCaseBind = t { tvrIdent = emptyId } } f e = emapEG f f e simplifyParms = transformParms {@@ -698,7 +704,7 @@ progress "Converting to Grin..." prog <- return $ atomizeApps True prog wdump FD.CoreMangled $ printProgram prog- x <- Grin.FromE.compile prog+ x <- Grin.FromE.compile (Grin.FromE.disambiguateProgram prog) when verbose $ Stats.print "Grin" Stats.theStats wdump FD.GrinInitial $ do dumpGrin "initial" x --x <- return $ normalizeGrin x@@ -751,6 +757,7 @@ lintCheckGrin x x <- createEvalApply x lintCheckGrin x+ wdump FD.GrinPosteval $ dumpGrin "posteval" x x <- evaluate $ Grin.SSimplify.simplify x lintCheckGrin x@@ -767,7 +774,7 @@ let dot = graphGrin grin fn = optOutName options writeFile (fn ++ "_grin.dot") dot- dumpGrin "final" grin+ wdump FD.Grin $ dumpGrin "final" grin @@ -787,8 +794,9 @@ | 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- debug = if fopts FO.Debug then ["-g"] else ["-DNDEBUG", "-O3", "-fomit-frame-pointer"]+ (map ("-l" ++) rls) ++ debug ++ unsafe ++ optCCargs options ++ boehmOpts ++ profileOpts+ debug = if fopts FO.Debug then ["-g"] else ["-fomit-frame-pointer","-O3"]+ unsafe = if fopts FO.Unsafe then ["-DNDEBUG"] else [] globalvar n c = "char " ++ n ++ "[] = \"" ++ c ++ "\";" compileC = do progress ("Running: " ++ comm)@@ -944,7 +952,7 @@ printProgram prog putErrLn $ ">>> program has repeated toplevel definitions" ++ pprint repeats maybeDie- let f (tvr@TVr { tvrIdent = n },e) | not $ isValidAtom n = do+ let f (tvr@TVr { tvrIdent = n },e) | not $ idIsNamed n = do onerr putErrLn $ ">>> non-unique name at top level: " ++ pprint tvr printProgram prog
− src/Name/Binary.hs
@@ -1,29 +0,0 @@-module Name.Binary() where--import Maybe-import Data.Monoid--import Data.Binary-import Name.Id-import Name.Name---instance Binary IdSet where- put ids = do- put [ id | id <- idSetToList ids, isNothing (fromId id)]- put [ n | id <- idSetToList ids, n <- fromId id]- get = do- (idl:: [Id]) <- get- (ndl:: [Name]) <- get- return (idSetFromDistinctAscList idl `mappend` idSetFromList (map toId ndl))---instance Binary a => Binary (IdMap a) where- put ids = do- put [ x | x@(id,_) <- idMapToList ids, isNothing (fromId id)]- put [ (n,v) | (id,v) <- idMapToList ids, n <- fromId id]- get = do- idl <- get- ndl <- get- return (idMapFromDistinctAscList idl `mappend` idMapFromList [ (toId n,v) | (n,v) <- ndl ])-
src/Name/Id.hs view
@@ -16,19 +16,25 @@ mapMaybeIdMap, idSetFromList, idToInt,+ idIsNamed,+ anonymous, idSetFromDistinctAscList, idMapFromList, idMapFromDistinctAscList, idSetToList, idMapToList,+ isEmptyId, emptyId,+ sillyId, newIds, newId, runIdNameT',- runIdNameT+ runIdNameT,+ toId,+ fromId )where -import Control.Monad.State+import qualified Control.Monad.State as State import Control.Monad.Reader import Data.Traversable import Data.Foldable@@ -36,8 +42,9 @@ import Data.Typeable import System.Random import Data.Bits-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS+import Data.Maybe (isJust)+import qualified Data.Map as Map+import qualified Data.Set as Set import StringTable.Atom import Util.HasSize@@ -45,46 +52,82 @@ import Util.NameMonad import Util.SetLike as S import Name.Name+import Doc.PPrint+import Doc.DocLike --- TODO - make this a newtype-type Id = Int--- data Id = Etherial Int | NoBind | Named Name | Unnamed Int+import Data.DeriveTH+import Data.Derive.All+import Data.Binary +data Id = Empty -- Empty binding. Like '\ _ -> ...'.+ | Etherial Int -- Special ids used for typechecking. They should never be exposed to the user.+ | Anonymous Int -- Anonymous id created by the compiler.+ | Named Name -- Named id created mostly by the user.+ deriving (Eq,Ord)++$(derive makeBinary ''Id)++instance Show Id where+ showsPrec n (Anonymous i) = showsPrec n i+ showsPrec n (Named x) = showsPrec n x+ showsPrec n (Etherial i) = showsPrec n (-i)+ showsPrec n Empty = showsPrec n "_"++instance DocLike d => PPrint d Id where+ pprint (Anonymous i) = pprint i+ pprint (Named n) = pprint n+ pprint (Etherial i) = pprint (-i)+ pprint Empty = pprint "_"+ -- IdSet +toId :: Name -> Id+toId x = Named x+--toId x = Id (fromAtom (toAtom x)) -newtype IdSet = IdSet IS.IntSet- deriving(Typeable,Monoid,HasSize,SetLike,BuildSet Id,ModifySet Id,IsEmpty,Eq,Ord)+fromId :: Monad m => Id -> m Name+fromId (Named n) = return n+fromId i = fail $ "Name.fromId: not a name " ++ show i +newtype IdSet = IdSet (Set.Set Id)+ deriving(Typeable,Monoid,HasSize,SetLike,BuildSet Id,ModifySet Id,IsEmpty,Eq,Ord,Binary)++ idSetToList :: IdSet -> [Id]-idSetToList (IdSet is) = IS.toList is+idSetToList (IdSet is) = Set.toList is idMapToList :: IdMap a -> [(Id,a)]-idMapToList (IdMap is) = IM.toList is+idMapToList (IdMap is) = Map.toList is idToInt :: Id -> Int-idToInt = id+idToInt (Anonymous i) = i+idToInt (Named n) = fromAtom (toAtom n)+idToInt (Etherial i) = -i+idToInt Empty = 0 +idIsNamed :: Id -> Bool+idIsNamed = isJust . fromId+ mapMaybeIdMap :: (a -> Maybe b) -> IdMap a -> IdMap b-mapMaybeIdMap fn (IdMap m) = IdMap (IM.mapMaybe fn m)+mapMaybeIdMap fn (IdMap m) = IdMap (Map.mapMaybe fn m) -- IdMap -newtype IdMap a = IdMap (IM.IntMap a)- deriving(Typeable,Monoid,HasSize,SetLike,BuildSet (Id,a),MapLike Id a,Functor,Traversable,Foldable,IsEmpty,Eq,Ord)+newtype IdMap a = IdMap (Map.Map Id a)+ deriving(Typeable,Monoid,HasSize,SetLike,BuildSet (Id,a),MapLike Id a,Functor,Traversable,Foldable,IsEmpty,Eq,Ord,Binary) idSetToIdMap :: (Id -> a) -> IdSet -> IdMap a-idSetToIdMap f (IdSet is) = IdMap $ IM.fromDistinctAscList [ (x,f x) | x <- IS.toAscList is]+idSetToIdMap f (IdSet is) = IdMap $ Map.fromDistinctAscList [ (x,f x) | x <- Set.toAscList is] idMapToIdSet :: IdMap a -> IdSet-idMapToIdSet (IdMap im) = IdSet $ (IM.keysSet im)+idMapToIdSet (IdMap im) = IdSet $ (Map.keysSet im) -- | Name monad transformer.-newtype IdNameT m a = IdNameT (StateT (IdSet, IdSet) m a)+newtype IdNameT m a = IdNameT (State.StateT (IdSet, IdSet) m a) deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO) instance (MonadReader r m) => MonadReader r (IdNameT m) where@@ -94,68 +137,72 @@ -- | Get bound and used names idNameBoundNames :: Monad m => IdNameT m IdSet idNameBoundNames = IdNameT $ do- (_used,bound) <- get+ (_used,bound) <- State.get return bound idNameUsedNames :: Monad m => IdNameT m IdSet idNameUsedNames = IdNameT $ do- (used,_bound) <- get+ (used,_bound) <- State.get return used -- | Run the name monad transformer. runIdNameT :: (Monad m) => IdNameT m a -> m a-runIdNameT (IdNameT x) = liftM fst $ runStateT x (mempty,mempty)+runIdNameT (IdNameT x) = liftM fst $ State.runStateT x (mempty,mempty) runIdNameT' :: (Monad m) => IdNameT m a -> m (a,IdSet) runIdNameT' (IdNameT x) = do- (r,(used,bound)) <- runStateT x (mempty,mempty)+ (r,(used,bound)) <- State.runStateT x (mempty,mempty) return (r,bound) fromIdNameT (IdNameT x) = x +instance GenName Id where+ genNames i = map anonymous [st, st + 2 ..] where+ st = abs i + 2 + abs i `mod` 2+ instance Monad m => NameMonad Id (IdNameT m) where addNames ns = IdNameT $ do- modify (\ (used,bound) -> (fromList ns `union` used, bound) )+ State.modify (\ (used,bound) -> (fromList ns `union` used, bound) ) addBoundNames ns = IdNameT $ do let nset = fromList ns- modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )+ State.modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) uniqueName n = IdNameT $ do- (used,bound) <- get- if n `member` bound then fromIdNameT newName else put (insert n used,insert n bound) >> return n+ (used,bound) <- State.get+ if n `member` bound then fromIdNameT newName else State.put (insert n used,insert n bound) >> return n newNameFrom vs = IdNameT $ do- (used,bound) <- get+ (used,bound) <- State.get let f (x:xs) | x `member` used = f xs | otherwise = x f [] = error "newNameFrom: finite list!" nn = f vs- put (insert nn used, insert nn bound)+ State.put (insert nn used, insert nn bound) return nn newName = IdNameT $ do- (used,bound) <- get- let genNames i = [st, st + 2 ..] where+ (used,bound) <- State.get+ let genNames i = map anonymous [st, st + 2 ..] where st = abs i + 2 + abs i `mod` 2 fromIdNameT $ newNameFrom (genNames (size used + size bound)) addNamesIdSet nset = IdNameT $ do- modify (\ (used,bound) -> (nset `union` used, bound) )+ State.modify (\ (used,bound) -> (nset `union` used, bound) ) addBoundNamesIdSet nset = IdNameT $ do- modify (\ (used,bound) -> (nset `union` used, nset `union` bound) )+ State.modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) addBoundNamesIdMap nmap = IdNameT $ do- modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where+ State.modify (\ (used,bound) -> (nset `union` used, nset `union` bound) ) where nset = idMapToIdSet nmap idSetFromDistinctAscList :: [Id] -> IdSet-idSetFromDistinctAscList ids = IdSet (IS.fromDistinctAscList ids)+idSetFromDistinctAscList ids = IdSet (Set.fromDistinctAscList ids) idSetFromList :: [Id] -> IdSet-idSetFromList ids = IdSet (IS.fromList ids)+idSetFromList ids = IdSet (Set.fromList ids) idMapFromList :: [(Id,a)] -> IdMap a-idMapFromList ids = IdMap (IM.fromList ids)+idMapFromList ids = IdMap (Map.fromList ids) idMapFromDistinctAscList :: [(Id,a)] -> IdMap a-idMapFromDistinctAscList ids = IdMap (IM.fromDistinctAscList ids)+idMapFromDistinctAscList ids = IdMap (Map.fromDistinctAscList ids) instance Show IdSet where@@ -173,29 +220,42 @@ -- positive and even - arbitrary numbers. etherialIds :: [Id]-etherialIds = [-2, -4 .. ]+etherialIds = map Etherial [2, 3 .. ] -isEtherialId id = id < 0+isEtherialId Etherial{} = True+isEtherialId _ = False -isInvalidId id = id <= 0+isInvalidId Etherial{} = True+isInvalidId Empty = True+isInvalidId _ = False +isEmptyId :: Id -> Bool+isEmptyId Empty = True+isEmptyId _ = False+ emptyId :: Id-emptyId = 0+emptyId = Empty +anonymous :: Int -> Id+anonymous x | x <= 0 = error "Anonymous variables must be positive numbers."+ | otherwise = Anonymous x +sillyId :: Id+sillyId = Etherial 1+ -- | find some temporary ids that are not members of the set, -- useful for generating a small number of local unique names. newIds :: IdSet -> [Id]-newIds ids = [ i | i <- [s, s + 2 ..] , i `notMember` ids ] where- s = 2 + (2 * size ids)+newIds ids = [ anonymous i | i <- [s ..] , anonymous i `notMember` ids ] where+ s = 1 + (size ids) newId :: Int -- ^ a seed value, useful for speeding up finding a unique id -> (Id -> Bool) -- ^ whether an Id is acceptable -> Id -- ^ your new Id newId seed check = head $ filter check ls where- ls = map mask $ randoms (mkStdGen seed)+ ls = map anonymous $ map mask $ randoms (mkStdGen seed) mask x = x .&. 0x0FFFFFFE
src/Name/Name.hs view
@@ -1,6 +1,6 @@ module Name.Name( NameType(..),- Name,+ Name(..), nameName, nameType, getModule,@@ -12,8 +12,8 @@ parseName, ffiExportName, isConstructorLike,- toId,- fromId,+-- toId,+-- fromId, Module, isTypeNamespace, isValNamespace,@@ -34,6 +34,11 @@ import GenUtil import FrontEnd.HsSyn +import Data.Word+import Data.ByteString (ByteString)++import Debug.Trace+ data NameType = TypeConstructor | DataConstructor@@ -46,9 +51,44 @@ deriving(Ord,Eq,Enum,Read,Show) -newtype Name = Name Atom- deriving(Ord,Eq,Typeable,Binary,ToAtom,FromAtom)+data Name = Name { nameAtom :: Atom+ , nameHash :: Word32+ , nameType :: NameType+ , nameModule :: Maybe String+ , nameIdent :: String+ }+ deriving(Typeable) --,Eq,Binary,ToAtom,FromAtom) +nameString :: Name -> ByteString+nameString = fromAtom . nameAtom++instance Binary Name where+ put = put . nameAtom+ get = fmap fromAtom get++instance FromAtom Name where+ fromAtom atom = let (nt, mod, i) = genNameParts atom+ name = Name { nameAtom = atom+ , nameHash = hash32 atom+ , nameType = nt+ , nameModule = mod+ , nameIdent = i }+ in name+instance ToAtom Name where+ toAtom = nameAtom++instance Eq Name where+ a == b = nameAtom a == nameAtom b+ a /= b = nameAtom a /= nameAtom b++-- Comparing ByteString's is relatively slow. Try to avoid it.+instance Ord Name where+ a `compare` b = case nameHash a `compare` nameHash b of+ EQ -> if nameAtom a == nameAtom b+ then EQ+ else nameString a `compare` nameString b+ other -> other+ isTypeNamespace TypeConstructor = True isTypeNamespace ClassName = True isTypeNamespace TypeVal = True@@ -73,10 +113,10 @@ createName _ "" i = error $ "createName: empty module " ++ i createName _ m "" = error $ "createName: empty ident " ++ m-createName t m i = Name $ toAtom $ (chr $ ord '1' + fromEnum t):m ++ ";" ++ i+createName t m i = fromAtom $ toAtom $ (chr $ ord '1' + fromEnum t):m ++ ";" ++ i createUName :: NameType -> String -> Name createUName _ "" = error $ "createUName: empty ident"-createUName t i = Name $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i+createUName t i = fromAtom $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i class ToName a where toName :: NameType -> a -> Name@@ -142,19 +182,22 @@ validMod _ = False -nameType :: Name -> NameType-nameType (Name a) = toEnum $ fromIntegral ( a `unsafeByteIndex` 0) - ord '1'+genNameType :: Atom -> NameType+genNameType a = toEnum $ fromIntegral ( a `unsafeByteIndex` 0) - ord '1' nameName :: Name -> HsName-nameName (Name a) = f $ tail (fromAtom a) where- f (';':xs) = UnQual $ HsIdent xs- f xs | (a,_:b) <- span (/= ';') xs = Qual (Module a) (HsIdent b)- f _ = error $ "invalid Name: " ++ (show $ (fromAtom a :: String))+nameName (Name _ _ _ (Just mod) i)+ = Qual (Module mod) (HsIdent i)+nameName (Name _ _ _ Nothing i)+ = UnQual $ HsIdent i -nameParts :: Name -> (NameType,Maybe String,String)-nameParts n@(Name a) = f $ tail (fromAtom a) where- f (';':xs) = (nameType n,Nothing,xs)- f xs = (nameType n,Just a,b) where+nameParts :: Name -> (NameType, Maybe String, String)+nameParts name = (nameType name, nameModule name, nameIdent name)++genNameParts :: Atom -> (NameType,Maybe String,String)+genNameParts n = f $ tail (fromAtom n) where+ f (';':xs) = (genNameType n,Nothing,xs)+ f xs = (genNameType n,Just a,b) where (a,_:b) = span (/= ';') xs instance Show Name where@@ -162,16 +205,6 @@ instance DocLike d => PPrint d Name where pprint n = text (show n)--toId :: Name -> Int-toId x = fromAtom (toAtom x)--fromId :: Monad m => Int -> m Name---fromId i | even i || i < 0 = fail $ "Name.fromId: not a name " ++ show i---fromId i | not $ isValidAtom i = fail $ "Name.fromId: not a name " ++ show i-fromId i = case intToAtom i of- Just a -> return $ Name a- Nothing -> fail $ "Name.fromId: not a name " ++ show i mapName :: (String -> String,String -> String) -> Name -> Name mapName (f,g) n = case nameParts n of
src/Name/Prim.hs view
@@ -1,3 +1,5 @@+{- Generated by utils/op_names.pl -}+ module Name.Prim where import Name.Name@@ -5,95 +7,95 @@ {-# NOINLINE tc_Int #-} tc_Int = toName TypeConstructor ("Lhc.Prim","Int") {-# NOINLINE dc_Int #-}-dc_Int = toName DataConstructor "Int#"+dc_Int = toName DataConstructor ("Lhc.Prim","Int") {-# NOINLINE tc_Integer #-} tc_Integer = toName TypeConstructor ("Lhc.Basics","Integer") {-# NOINLINE dc_Integer #-}-dc_Integer = toName DataConstructor "Integer#"+dc_Integer = toName DataConstructor ("Lhc.Basics","Integer") {-# NOINLINE tc_Int8 #-} tc_Int8 = toName TypeConstructor ("Data.Int","Int8") {-# NOINLINE dc_Int8 #-}-dc_Int8 = toName DataConstructor "Int8#"+dc_Int8 = toName DataConstructor ("Data.Int","Int8") {-# NOINLINE tc_Int16 #-} tc_Int16 = toName TypeConstructor ("Data.Int","Int16") {-# NOINLINE dc_Int16 #-}-dc_Int16 = toName DataConstructor "Int16#"+dc_Int16 = toName DataConstructor ("Data.Int","Int16") {-# NOINLINE tc_Int32 #-} tc_Int32 = toName TypeConstructor ("Data.Int","Int32") {-# NOINLINE dc_Int32 #-}-dc_Int32 = toName DataConstructor "Int32#"+dc_Int32 = toName DataConstructor ("Data.Int","Int32") {-# NOINLINE tc_Int64 #-} tc_Int64 = toName TypeConstructor ("Data.Int","Int64") {-# NOINLINE dc_Int64 #-}-dc_Int64 = toName DataConstructor "Int64#"+dc_Int64 = toName DataConstructor ("Data.Int","Int64") {-# NOINLINE tc_IntMax #-} tc_IntMax = toName TypeConstructor ("Data.Int","IntMax") {-# NOINLINE dc_IntMax #-}-dc_IntMax = toName DataConstructor "IntMax#"+dc_IntMax = toName DataConstructor ("Data.Int","IntMax") {-# NOINLINE tc_IntPtr #-} tc_IntPtr = toName TypeConstructor ("Data.Int","IntPtr") {-# NOINLINE dc_IntPtr #-}-dc_IntPtr = toName DataConstructor "IntPtr#"+dc_IntPtr = toName DataConstructor ("Data.Int","IntPtr") {-# NOINLINE tc_Word #-} tc_Word = toName TypeConstructor ("Data.Word","Word") {-# NOINLINE dc_Word #-}-dc_Word = toName DataConstructor "Word#"+dc_Word = toName DataConstructor ("Data.Word","Word") {-# NOINLINE tc_Word8 #-} tc_Word8 = toName TypeConstructor ("Data.Word","Word8") {-# NOINLINE dc_Word8 #-}-dc_Word8 = toName DataConstructor "Word8#"+dc_Word8 = toName DataConstructor ("Data.Word","Word8") {-# NOINLINE tc_Word16 #-} tc_Word16 = toName TypeConstructor ("Data.Word","Word16") {-# NOINLINE dc_Word16 #-}-dc_Word16 = toName DataConstructor "Word16#"+dc_Word16 = toName DataConstructor ("Data.Word","Word16") {-# NOINLINE tc_Word32 #-} tc_Word32 = toName TypeConstructor ("Data.Word","Word32") {-# NOINLINE dc_Word32 #-}-dc_Word32 = toName DataConstructor "Word32#"+dc_Word32 = toName DataConstructor ("Data.Word","Word32") {-# NOINLINE tc_Word64 #-} tc_Word64 = toName TypeConstructor ("Data.Word","Word64") {-# NOINLINE dc_Word64 #-}-dc_Word64 = toName DataConstructor "Word64#"+dc_Word64 = toName DataConstructor ("Data.Word","Word64") {-# NOINLINE tc_WordMax #-} tc_WordMax = toName TypeConstructor ("Data.Word","WordMax") {-# NOINLINE dc_WordMax #-}-dc_WordMax = toName DataConstructor "WordMax#"+dc_WordMax = toName DataConstructor ("Data.Word","WordMax") {-# NOINLINE tc_WordPtr #-} tc_WordPtr = toName TypeConstructor ("Data.Word","WordPtr") {-# NOINLINE dc_WordPtr #-}-dc_WordPtr = toName DataConstructor "WordPtr#"+dc_WordPtr = toName DataConstructor ("Data.Word","WordPtr") {-# NOINLINE tc_CChar #-} tc_CChar = toName TypeConstructor ("Foreign.C.Types","CChar") {-# NOINLINE dc_CChar #-}-dc_CChar = toName DataConstructor "CChar#"+dc_CChar = toName DataConstructor ("Foreign.C.Types","CChar") {-# NOINLINE tc_CShort #-} tc_CShort = toName TypeConstructor ("Foreign.C.Types","CShort") {-# NOINLINE dc_CShort #-}-dc_CShort = toName DataConstructor "CShort#"+dc_CShort = toName DataConstructor ("Foreign.C.Types","CShort") {-# NOINLINE tc_CInt #-} tc_CInt = toName TypeConstructor ("Foreign.C.Types","CInt") {-# NOINLINE dc_CInt #-}-dc_CInt = toName DataConstructor "CInt#"+dc_CInt = toName DataConstructor ("Foreign.C.Types","CInt") {-# NOINLINE tc_CUInt #-} tc_CUInt = toName TypeConstructor ("Foreign.C.Types","CUInt") {-# NOINLINE dc_CUInt #-}-dc_CUInt = toName DataConstructor "CUInt#"+dc_CUInt = toName DataConstructor ("Foreign.C.Types","CUInt") {-# NOINLINE tc_CSize #-} tc_CSize = toName TypeConstructor ("Foreign.C.Types","CSize") {-# NOINLINE dc_CSize #-}-dc_CSize = toName DataConstructor "CSize#"+dc_CSize = toName DataConstructor ("Foreign.C.Types","CSize") {-# NOINLINE tc_CWchar #-} tc_CWchar = toName TypeConstructor ("Foreign.C.Types","CWchar") {-# NOINLINE dc_CWchar #-}-dc_CWchar = toName DataConstructor "CWchar#"+dc_CWchar = toName DataConstructor ("Foreign.C.Types","CWchar") {-# NOINLINE tc_CWint #-} tc_CWint = toName TypeConstructor ("Foreign.C.Types","CWint") {-# NOINLINE dc_CWint #-}-dc_CWint = toName DataConstructor "CWint#"+dc_CWint = toName DataConstructor ("Foreign.C.Types","CWint") {-# NOINLINE tc_CTime #-} tc_CTime = toName TypeConstructor ("Foreign.C.Types","CTime") {-# NOINLINE dc_CTime #-}-dc_CTime = toName DataConstructor "CTime#"+dc_CTime = toName DataConstructor ("Foreign.C.Types","CTime") {-# NOINLINE rt_bits16 #-} rt_bits16 = toName RawType "bits16"@@ -167,6 +169,14 @@ tc_BitsPtr = toName TypeConstructor ("Lhc.Types","BitsPtr_") {-# NOINLINE tc_BitsMax #-} tc_BitsMax = toName TypeConstructor ("Lhc.Types","BitsMax_")+{-# NOINLINE tc_BitsSize #-}+tc_BitsSize = toName TypeConstructor ("Lhc.Types","BitsSize_t_")+{-# NOINLINE tc_BitsShort #-}+tc_BitsShort = toName TypeConstructor ("Lhc.Types","BitsShort_")+{-# NOINLINE tc_BitsInt #-}+tc_BitsInt = toName TypeConstructor ("Lhc.Types","BitsInt_")+{-# NOINLINE tc_BitsLong #-}+tc_BitsLong = toName TypeConstructor ("Lhc.Types","BitsLong_") {-# NOINLINE tc_Float32 #-} tc_Float32 = toName TypeConstructor ("Lhc.Types","Float32_") {-# NOINLINE tc_Float64 #-}
src/Options.hs view
@@ -99,7 +99,7 @@ optDefs = [], optDump = [], optStale = [],- optFOpts = ["default"],+ optFOpts = ["default","lint"], optCCargs = [], optHoDir = Nothing, optHoCache = Nothing,
src/PrimitiveOperators.hs view
@@ -22,11 +22,16 @@ import Name.VConsts import Support.CanType import qualified Cmm.Op as Op-+import Name.Id nameToOpTy n = do RawType <- return $ nameType n; Op.readTy (show n) -tPtr t = ELit (litCons { litName = tc_Ptr, litArgs = [t], litType = eStar, litAliasFor = Just (ELam tvr { tvrIdent = 2, tvrType = eStar} (ELit litCons { litName = tc_Addr, litType = eStar })) })+tPtr t = ELit (litCons { litName = tc_Ptr+ , litArgs = [t]+ , litType = eStar+ , litAliasFor = Just (ELam tvr { tvrIdent = anonymous 2+ , tvrType = eStar}+ (ELit litCons { litName = tc_Addr, litType = eStar })) }) create_integralCast conv c1 t1 c2 t2 e t = eCase e [Alt (litCons { litName = c1, litArgs = [tvra], litType = te }) cc] Unknown where te = getType e@@ -34,8 +39,8 @@ ELit LitCons { litName = n2, litArgs = [] } = t2 Just n1' = nameToOpTy n1 Just n2' = nameToOpTy n2- tvra = tVr 4 t1- tvrb = tVr 6 t2+ tvra = tVr (anonymous 4) t1+ tvrb = tVr (anonymous 6) t2 cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else eStrictLet tvrb (EPrim (APrim (Op (Op.ConvOp conv n1') n2') mempty) [EVar tvra] t2) (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t })) @@ -76,28 +81,28 @@ ot_int = stringToOpTy "bits32" op_aIa op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') dc_Int tvrb wtd))) where- tvra' = tVr 2 t- tvrb' = tVr 4 tInt- tvra = tVr 6 st- tvrb = tVr 8 intt- tvrc = tVr 10 st+ tvra' = tVr (anonymous 2) t+ tvrb' = tVr (anonymous 4) tInt+ tvra = tVr (anonymous 6) st+ tvrb = tVr (anonymous 8) intt+ tvrc = tVr (anonymous 10) st st = rawType ct intt = rawType "bits32" wtd = eStrictLet tvrc (oper_aIa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc)) rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t }) op_aaa op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where- tvra' = tVr 2 t- tvrb' = tVr 4 t- tvra = tVr 6 st- tvrb = tVr 8 st- tvrc = tVr 10 st+ tvra' = tVr (anonymous 2) t+ tvrb' = tVr (anonymous 4) t+ tvra = tVr (anonymous 6) st+ tvrb = tVr (anonymous 8) st+ tvrc = tVr (anonymous 10) st st = rawType ct wtd = eStrictLet tvrc (oper_aaa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc)) rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t }) op_aa op ct cn t = ELam tvra' (unbox' (EVar tvra') cn tvra wtd) where- tvra' = tVr 2 t- tvra = tVr 6 st- tvrc = tVr 10 st+ tvra' = tVr (anonymous 2) t+ tvra = tVr (anonymous 6) st+ tvrc = tVr (anonymous 10) st st = rawType ct wtd = eStrictLet tvrc (oper_aa op ct (EVar tvra)) (rebox (EVar tvrc)) rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = t })@@ -112,19 +117,19 @@ -- rebox x = ELit (litCons { litName = dc_Int, litArgs = [x], litType = t }) op_aaB op ct cn t = ELam tvra' (ELam tvrb' (unbox' (EVar tvra') cn tvra (unbox' (EVar tvrb') cn tvrb wtd))) where- tvra' = tVr 2 t- tvrb' = tVr 4 t- tvra = tVr 6 st- tvrb = tVr 8 st- tvrc = tVr 10 tBoolzh+ tvra' = tVr (anonymous 2) t+ tvrb' = tVr (anonymous 4) t+ tvra = tVr (anonymous 6) st+ tvrb = tVr (anonymous 8) st+ tvrc = tVr (anonymous 10) tBoolzh st = rawType ct wtd = eStrictLet tvrc (oper_aaB op ct (EVar tvra) (EVar tvrb)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar tvrc], litType = tBool })) -- (caseof (EVar tvrc)) -- caseof x = eCase x [Alt zeroI vFalse] vTrue build_abs ct cn v = unbox' v cn tvra (eCase (oper_aaB Op.Lt ct (EVar tvra) zero) [Alt lFalsezh (rebox $ EVar tvra), Alt lTruezh fs] Unknown) where te = getType v- tvra = tVr 2 st- tvrb = tVr 4 st+ tvra = tVr (anonymous 2) st+ tvrb = tVr (anonymous 4) st zero = ELit $ LitInt 0 st st = rawType ct fs = eStrictLet tvrb (oper_aa Op.Neg ct (EVar tvra)) (rebox (EVar tvrb))@@ -134,12 +139,12 @@ build_fabs ct cn v = unbox' v cn tvra (rebox (oper_aa Op.FAbs ct (EVar tvra))) where te = getType v- tvra = tVr 2 st+ tvra = tVr (anonymous 2) st st = rawType ct rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te }) build_usignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (rebox (ELit one))) where- tvra = tVr 2 st+ tvra = tVr (anonymous 2) st te = getType v st = rawType ct zero :: Lit a E@@ -148,7 +153,7 @@ rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te }) build_signum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.Lt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where- tvra = tVr 2 st+ tvra = tVr (anonymous 2) st te = getType v st = rawType ct zero :: Lit a E@@ -159,7 +164,7 @@ build_fsignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.FLt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where- tvra = tVr 2 st+ tvra = tVr (anonymous 2) st te = getType v st = rawType ct zero :: Lit a E@@ -170,20 +175,20 @@ buildPeek cn t p = ELam tvr $ ELam tvrWorld (unbox' (EVar tvr) dc_Addr tvr' rest) where- tvr = (tVr 2 (tPtr t))- tvr' = tVr 4 (rawType "bits<ptr>")- tvrWorld2 = tVr 258 tWorld__- tvrWorld = tVr 256 tWorld__- rtVar = tVr 260 (rawType p)- rtVar' = tVr 262 t+ tvr = (tVr (anonymous 2) (tPtr t))+ tvr' = tVr (anonymous 4) (rawType "bits<ptr>")+ tvrWorld2 = tVr (anonymous 258) tWorld__+ tvrWorld = tVr (anonymous 256) tWorld__+ rtVar = tVr (anonymous 260) (rawType p)+ rtVar' = tVr (anonymous 262) t rest = eCaseTup' (EPrim (APrim (Peek (stringToOpTy p)) mempty) [EVar tvrWorld, EVar tvr'] (ltTuple' [tWorld__,rawType p])) [tvrWorld2,rtVar] (eLet rtVar' (ELit $ litCons { litName = cn, litArgs = [EVar rtVar], litType = t }) $ eJustIO (EVar tvrWorld2) (EVar rtVar') ) buildPoke cn t p = ELam ptr_tvr $ ELam v_tvr $ createIO_ $ (\tw -> unbox' (EVar ptr_tvr) dc_Addr ptr_tvr' $ unbox' (EVar v_tvr) cn v_tvr' $ EPrim (APrim (Poke (stringToOpTy p)) mempty) [EVar tw, EVar ptr_tvr', EVar v_tvr'] tWorld__) where- ptr_tvr = (tVr 2 (tPtr t))- v_tvr = tVr 4 t- ptr_tvr' = (tVr 6 (rawType "bits<ptr>"))- v_tvr' = tVr 8 (rawType p)+ ptr_tvr = (tVr (anonymous 2) (tPtr t))+ v_tvr = tVr (anonymous 4) t+ ptr_tvr' = (tVr (anonymous 6) (rawType "bits<ptr>"))+ v_tvr' = tVr (anonymous 8) (rawType p) toIO :: E -> E -> E toIO t x = x@@ -195,8 +200,8 @@ rtVar = tVr 260 t -} createIO_ pv = toIO tUnit (ELam tvrWorld $ eStrictLet tvrWorld2 (pv tvrWorld) (eJustIO (EVar tvrWorld2) vUnit)) where- tvrWorld2 = tVr 258 tWorld__- tvrWorld = tVr 256 tWorld__+ tvrWorld2 = tVr (anonymous 258) tWorld__+ tvrWorld = tVr (anonymous 256) tWorld__ prim_number cn v t et = ELit litCons { litName = cn, litArgs = [ELit (LitInt v t)], litType = et }@@ -219,11 +224,11 @@ | otherwise = EPrim (APrim (PrimTypeInfo { primArgTy = stringToOpTy s, primRetTy = ot_int, primTypeInfo = PrimSizeOf }) mempty) [] tIntzh -v2_Int = tVr 2 tInt-v2_Integer = tVr 2 tInteger-v2 t = tVr 2 t+v2_Int = tVr (anonymous 2) tInt+v2_Integer = tVr (anonymous 2) tInteger+v2 t = tVr (anonymous 2) t -v0 t = tVr 0 t+v0 t = tVr emptyId t {-# NOINLINE constantMethods #-} {-# NOINLINE primitiveInsts #-}@@ -1101,6 +1106,7 @@ ] t_Data_Word_WordMax = ELit litCons { litName = tc_WordMax, litType = eStar}+t_Lhc_Basics_Integer = ELit litCons { litName = tc_Integer, litType = eStar} t_Foreign_C_Types_CInt = ELit litCons { litName = tc_CInt, litType = eStar} t_Data_Word_Word64 = ELit litCons { litName = tc_Word64, litType = eStar} t_Data_Int_IntMax = ELit litCons { litName = tc_IntMax, litType = eStar}@@ -1108,10 +1114,9 @@ t_Foreign_C_Types_CShort = ELit litCons { litName = tc_CShort, litType = eStar} t_Data_Int_Int8 = ELit litCons { litName = tc_Int8, litType = eStar} t_Foreign_C_Types_CChar = ELit litCons { litName = tc_CChar, litType = eStar}+t_Lhc_Prim_Int = ELit litCons { litName = tc_Int, litType = eStar} t_Data_Word_Word = ELit litCons { litName = tc_Word, litType = eStar}-t_Lhc_Basics_Integer = ELit litCons { litName = tc_Integer, litType = eStar} t_Data_Int_Int16 = ELit litCons { litName = tc_Int16, litType = eStar}-t_Lhc_Prim_Int = ELit litCons { litName = tc_Int, litType = eStar} t_Data_Word_Word8 = ELit litCons { litName = tc_Word8, litType = eStar} t_Data_Word_Word32 = ELit litCons { litName = tc_Word32, litType = eStar} t_Foreign_C_Types_CWchar = ELit litCons { litName = tc_CWchar, litType = eStar}@@ -1125,6 +1130,7 @@ t_Data_Word_WordPtr = ELit litCons { litName = tc_WordPtr, litType = eStar} tc_Data_Word_WordMax = TCon (Tycon tc_WordMax kindStar)+tc_Lhc_Basics_Integer = TCon (Tycon tc_Integer kindStar) tc_Foreign_C_Types_CInt = TCon (Tycon tc_CInt kindStar) tc_Data_Word_Word64 = TCon (Tycon tc_Word64 kindStar) tc_Data_Int_IntMax = TCon (Tycon tc_IntMax kindStar)@@ -1132,10 +1138,9 @@ tc_Foreign_C_Types_CShort = TCon (Tycon tc_CShort kindStar) tc_Data_Int_Int8 = TCon (Tycon tc_Int8 kindStar) tc_Foreign_C_Types_CChar = TCon (Tycon tc_CChar kindStar)+tc_Lhc_Prim_Int = TCon (Tycon tc_Int kindStar) tc_Data_Word_Word = TCon (Tycon tc_Word kindStar)-tc_Lhc_Basics_Integer = TCon (Tycon tc_Integer kindStar) tc_Data_Int_Int16 = TCon (Tycon tc_Int16 kindStar)-tc_Lhc_Prim_Int = TCon (Tycon tc_Int kindStar) tc_Data_Word_Word8 = TCon (Tycon tc_Word8 kindStar) tc_Data_Word_Word32 = TCon (Tycon tc_Word32 kindStar) tc_Foreign_C_Types_CWchar = TCon (Tycon tc_CWchar kindStar)@@ -1148,21 +1153,21 @@ tc_Data_Int_IntPtr = TCon (Tycon tc_IntPtr kindStar) tc_Data_Word_WordPtr = TCon (Tycon tc_WordPtr kindStar) -n_Lhc_Order_Eq = toClassName "Lhc.Order.Eq"-n_Lhc_Order_Ord = toClassName "Lhc.Order.Ord" n_Lhc_Num_Integral = toClassName "Lhc.Num.Integral"-n_Data_Bits_Bits = toClassName "Data.Bits.Bits" n_Lhc_Num_Num = toClassName "Lhc.Num.Num"-n_Foreign_Storable_Storable = toClassName "Foreign.Storable.Storable"+n_Data_Bits_Bits = toClassName "Data.Bits.Bits"+n_Lhc_Order_Eq = toClassName "Lhc.Order.Eq" n_Lhc_Enum_Bounded = toClassName "Lhc.Enum.Bounded"+n_Lhc_Order_Ord = toClassName "Lhc.Order.Ord"+n_Foreign_Storable_Storable = toClassName "Foreign.Storable.Storable" -{-# NOINLINE n_Lhc_Order_Eq #-}-{-# NOINLINE n_Lhc_Order_Ord #-} {-# NOINLINE n_Lhc_Num_Integral #-}-{-# NOINLINE n_Data_Bits_Bits #-} {-# NOINLINE n_Lhc_Num_Num #-}-{-# NOINLINE n_Foreign_Storable_Storable #-}+{-# NOINLINE n_Data_Bits_Bits #-}+{-# NOINLINE n_Lhc_Order_Eq #-} {-# NOINLINE n_Lhc_Enum_Bounded #-}+{-# NOINLINE n_Lhc_Order_Ord #-}+{-# NOINLINE n_Foreign_Storable_Storable #-}
src/Stats.hs view
@@ -93,10 +93,8 @@ drawSubTrees (t:ts) = {-[vLine] :-} shift branch (C.vLine ++ " ") (draw t) ++ drawSubTrees ts - branch | dump FD.SquareStats = C.lTee ++ C.hLine- | otherwise = C.lTee ++ [chr 0x2574]- lastBranch | dump FD.SquareStats = C.llCorner ++ C.hLine- | otherwise = [chr 0x2570, chr 0x2574]+ branch = C.lTee ++ C.hLine+ lastBranch = C.llCorner ++ C.hLine shift first other = zipWith (++) (first : repeat other) --vLine = chr 0x254F
− src/Support/MapBinaryInstance.hs
@@ -1,39 +0,0 @@-{-- We can't use the standard instances for serializing maps containing- Atoms or Ids. Atoms are compared using their unique id which depends- on the order in which they were created. This completely invalidates- the standard map instances which rely on- 'fromAscDistinctList . toAscDistinctList = id' to be true.- Once we've gotten rid of StringTable.Atoms, we can get rid of this- module as well.--}-module Support.MapBinaryInstance where---import Data.Binary-import Data.Word-import Data.Map as Map-import Data.Set as Set-import Control.Monad--putMap :: (Binary k,Ord k,Binary v) => Map.Map k v -> Put-putMap x = do- put (fromIntegral $ Map.size x :: Word32)- mapM_ put (Map.toList x)-getMap :: (Binary k,Ord k,Binary v) => Get (Map.Map k v)-getMap = do- sz <- get :: Get Word32- ls <- replicateM (fromIntegral sz) get- return (Map.fromList ls)---putSet :: (Binary a,Ord a) => Set.Set a -> Put-putSet x = do- put (fromIntegral $ Set.size x :: Word32)- mapM_ put (Set.toList x)--getSet :: (Binary a,Ord a) => Get (Set.Set a)-getSet = do- sz <- get :: Get Word32- ls <- replicateM (fromIntegral sz) get- return (Set.fromList ls)
src/Util/NameMonad.hs view
@@ -31,10 +31,16 @@ -- | Generate a list of candidate names given a seed genNames :: Int -> [n] +{- instance GenName Int where genNames i = [st, st + 2 ..] where st = abs i + 2 + abs i `mod` 2-+-}+{-+instance GenName Id where+ genNames i = map unnamed [st, st + 2 ..] where+ st = abs i + 2 + abs i `mod` 2+-} -- | Generate an infinite list of names not present in the given set. freeNames :: (Ord n,GenName n) => Set.Set n -> [n] freeNames s = filter (not . (`Set.member` s)) (genNames (Set.size s))
− src/Util/TrueSet.hs
@@ -1,60 +0,0 @@-module Util.TrueSet(- TrueSet,- fromList,- member,- empty,- full,- singleton,- insert,- delete,- unions,- union,- intersection,- intersects,- difference,- (\\)- ) where--import qualified Data.Set as Set--infixl 9 \\---data TrueSet a = TrueSet (Set.Set a) Bool--False `xor` y = y-True `xor` y = not y--fromList xs = TrueSet (Set.fromList xs) False-member x (TrueSet s inv) = inv `xor` (Set.member x s)--invert (TrueSet x y) = TrueSet x (not y)-empty = TrueSet Set.empty False-full = TrueSet Set.empty False-singleton x = TrueSet (Set.singleton x) False-insert x (TrueSet s False) = TrueSet (Set.insert x s) False-insert x (TrueSet s True) = TrueSet (Set.delete x s) True-delete x (TrueSet s False) = TrueSet (Set.delete x s) False-delete x (TrueSet s True) = TrueSet (Set.insert x s) True--unions xs = foldlStrict union empty xs-intersects xs = foldlStrict intersection full xs--foldlStrict f z xs- = case xs of- [] -> z- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)--difference x y = x `intersection` invert y-m1 \\ m2 = difference m1 m2--(TrueSet x True) `intersection` (TrueSet y True) = TrueSet (x `Set.union` y) True-(TrueSet x False) `intersection` (TrueSet y False) = TrueSet (x `Set.intersection` y) False-(TrueSet x True) `intersection` (TrueSet y False) = TrueSet (y Set.\\ x) False-(TrueSet x False) `intersection` (TrueSet y True) = TrueSet (x Set.\\ y) False-(TrueSet x True) `union` (TrueSet y True) = TrueSet (x `Set.intersection` y) True-(TrueSet x False) `union` (TrueSet y False) = TrueSet (x `Set.union` y) False-(TrueSet x True) `union` (TrueSet y False) = TrueSet (x Set.\\ y) True-(TrueSet x False) `union` (TrueSet y True) = TrueSet (y Set.\\ x) True--