WARNING! Access to this system is limited to authorised users only.
Unauthorised users may be subject to prosecution.
Unauthorised access to this system is a criminal offence under Australian law (Federal Crimes Act 1914 Part VIA)
It is a criminal offence to:
(1) Obtain access to data without authority. -Penalty 2 years imprisonment.
(2) Damage, delete, alter or insert data without authority. -Penalty 10 years imprisonment.
User activity is monitored and recorded. Anyone using this system expressly consents to such monitoring and recording.

Commit 70a4766e authored by nathyong's avatar nathyong
Browse files

Add GHC wired-in libraries

parent e2561239
......@@ -22,7 +22,6 @@ import System.Environment (getArgs)
import System.Exit (exitFailure)
import qualified Data.Sequence as Seq
import qualified Data.Map.Strict as M
import System.Directory (listDirectory)
import qualified Language.Haskell.GHC.Simple as GHC.Simple
import Language.Haskell.GHC.Simple.Extra ()
......@@ -35,6 +34,8 @@ import Mu.AST
import Mu.Impl.RefImpl2
import Mu.Interface
import Debug.Trace
compilerConfig :: CompConfig
compilerConfig =
GHC.Simple.disableCodeGen $
......@@ -49,26 +50,27 @@ main :: IO ()
main = do
inputFiles <- getArgs
b <- GHC.Simple.compileWith compilerConfig compileMu inputFiles
libresults <- compileLibraryFiles
libresults <- mapM compileLibraryFiles libraryFiles
case b of
Success results _ _ -> do
doResults lives $ mergeResults $ (loadPrim : libresults ++ results')
doResults lives $ mergeResults $ (loadPrim : concat libresults ++ results')
where
results' = fmap modCompiledModule (results)
lives = toList $ foldMap getDefns results'
getDefns (defns, _, _) = fmap toName defns
Failure _ _ -> exitFailure
compileLibraryFiles :: IO [MuResult]
compileLibraryFiles = do
b <- getLibraryFiles >>= GHC.Simple.compileWith libconfig compileMu
compileLibraryFiles :: (String, [FilePath]) -> IO [MuResult]
compileLibraryFiles (packageKey, files) = do
traceM ("Compiling the library file " ++ packageKey)
b <- GHC.Simple.compileWith libconfig compileMu files
case b of
Success results _ _ -> return $ fmap modCompiledModule results
Failure _ _ -> error "Could not compile internal bundle"
where
libconfig = compilerConfig
{ cfgGhcFlags =
["-this-unit-id", "ghc-prim", "-ddump-stg", "-ddump-to-file"]
["-this-unit-id", packageKey, "-ddump-stg", "-ddump-to-file"]
}
doResults :: [Name] -> MuMergedResult -> IO ()
......@@ -93,12 +95,222 @@ doResults liveObjectNames (defns, topClosures, mainFunction) = do
where
defns' = M.elems defns
getLibraryFiles :: IO [FilePath]
getLibraryFiles = process =<< mapM listDirectory'
["/Users/nathan/projects/microvm/anuhc/anuhc-prim/GHC/"]
-- | A list of all library files, indexed by their package-key.
-- TODO: fix this.
libraryFiles :: [(String, [FilePath])]
libraryFiles = [ ("ghc-prim", prefix ghcPrimFiles)
, ("base", prefix baseFiles)
]
where
process = return . (filter (".hs" `isSuffixOf`) . concat)
listDirectory' dir = listDirectory dir >>= return . (fmap (dir ++))
prefix = fmap ("/Users/nathan/projects/microvm/anuhc/libraries/" ++)
ghcPrimFiles =
[ "ghc-prim/GHC/CString.hs"
, "ghc-prim/GHC/Classes.hs"
, "ghc-prim/GHC/Debug.hs"
, "ghc-prim/GHC/IntWord64.hs"
, "ghc-prim/GHC/Magic.hs"
-- , "ghc-prim/GHC/PrimopWrappers.hs"
, "ghc-prim/GHC/Tuple.hs"
, "ghc-prim/GHC/Types.hs"
]
baseFiles =
[ "base/Control/Applicative.hs"
, "base/Control/Arrow.hs"
, "base/Control/Category.hs"
, "base/Control/Concurrent.hs"
, "base/Control/Concurrent/Chan.hs"
, "base/Control/Concurrent/MVar.hs"
, "base/Control/Concurrent/QSem.hs"
, "base/Control/Concurrent/QSemN.hs"
, "base/Control/Exception.hs"
, "base/Control/Exception/Base.hs"
, "base/Control/Monad.hs"
, "base/Control/Monad/Fail.hs"
, "base/Control/Monad/Fix.hs"
, "base/Control/Monad/Instances.hs"
, "base/Control/Monad/IO/Class.hs"
, "base/Control/Monad/ST.hs"
, "base/Control/Monad/ST/Lazy.hs"
, "base/Control/Monad/ST/Lazy/Safe.hs"
, "base/Control/Monad/ST/Lazy/Unsafe.hs"
, "base/Control/Monad/ST/Safe.hs"
, "base/Control/Monad/ST/Strict.hs"
, "base/Control/Monad/ST/Unsafe.hs"
, "base/Control/Monad/Zip.hs"
, "base/Data/Bifunctor.hs"
, "base/Data/Bits.hs"
, "base/Data/Bool.hs"
, "base/Data/Char.hs"
, "base/Data/Coerce.hs"
, "base/Data/Complex.hs"
, "base/Data/Data.hs"
, "base/Data/Dynamic.hs"
, "base/Data/Either.hs"
, "base/Data/Eq.hs"
, "base/Data/Fixed.hs"
, "base/Data/Foldable.hs"
, "base/Data/Function.hs"
, "base/Data/Functor.hs"
, "base/Data/Functor/Classes.hs"
, "base/Data/Functor/Compose.hs"
, "base/Data/Functor/Const.hs"
, "base/Data/Functor/Identity.hs"
, "base/Data/Functor/Product.hs"
, "base/Data/Functor/Sum.hs"
, "base/Data/IORef.hs"
, "base/Data/Int.hs"
, "base/Data/Ix.hs"
, "base/Data/Kind.hs"
, "base/Data/List.hs"
, "base/Data/List/NonEmpty.hs"
, "base/Data/Maybe.hs"
, "base/Data/Monoid.hs"
, "base/Data/Ord.hs"
, "base/Data/Proxy.hs"
, "base/Data/Ratio.hs"
, "base/Data/Semigroup.hs"
, "base/Data/STRef.hs"
, "base/Data/STRef/Lazy.hs"
, "base/Data/STRef/Strict.hs"
, "base/Data/String.hs"
, "base/Data/Traversable.hs"
, "base/Data/Tuple.hs"
, "base/Data/Type/Bool.hs"
, "base/Data/Type/Coercion.hs"
, "base/Data/Type/Equality.hs"
, "base/Data/Typeable.hs"
, "base/Data/Typeable/Internal.hs"
, "base/Data/Unique.hs"
, "base/Data/Version.hs"
, "base/Data/Void.hs"
, "base/Data/Word.hs"
, "base/Debug/Trace.hs"
, "base/Foreign.hs"
, "base/Foreign/C.hs"
, "base/Foreign/C/Error.hs"
, "base/Foreign/C/String.hs"
, "base/Foreign/C/Types.hs"
, "base/Foreign/Concurrent.hs"
, "base/Foreign/ForeignPtr.hs"
, "base/Foreign/ForeignPtr/Safe.hs"
, "base/Foreign/ForeignPtr/Unsafe.hs"
, "base/Foreign/Marshal.hs"
, "base/Foreign/Marshal/Alloc.hs"
, "base/Foreign/Marshal/Array.hs"
, "base/Foreign/Marshal/Error.hs"
, "base/Foreign/Marshal/Pool.hs"
, "base/Foreign/Marshal/Safe.hs"
, "base/Foreign/Marshal/Unsafe.hs"
, "base/Foreign/Marshal/Utils.hs"
, "base/Foreign/Ptr.hs"
, "base/Foreign/Safe.hs"
, "base/Foreign/StablePtr.hs"
, "base/Foreign/Storable.hs"
, "base/GHC/Arr.hs"
, "base/GHC/Base.hs"
, "base/GHC/Char.hs"
, "base/GHC/Conc.hs"
, "base/GHC/Conc/IO.hs"
, "base/GHC/Conc/Signal.hs"
, "base/GHC/Conc/Sync.hs"
, "base/GHC/ConsoleHandler.hs"
, "base/GHC/Constants.hs"
, "base/GHC/Desugar.hs"
, "base/GHC/Enum.hs"
, "base/GHC/Environment.hs"
, "base/GHC/Err.hs"
, "base/GHC/Exception.hs"
, "base/GHC/ExecutionStack.hs"
, "base/GHC/ExecutionStack/Internal.hs"
, "base/GHC/Exts.hs"
, "base/GHC/Fingerprint.hs"
, "base/GHC/Fingerprint/Type.hs"
, "base/GHC/Float.hs"
, "base/GHC/Float/ConversionUtils.hs"
, "base/GHC/Float/RealFracMethods.hs"
, "base/GHC/Foreign.hs"
, "base/GHC/ForeignPtr.hs"
, "base/GHC/GHCi.hs"
, "base/GHC/Generics.hs"
, "base/GHC/IO.hs"
, "base/GHC/IO/Buffer.hs"
, "base/GHC/IO/BufferedIO.hs"
, "base/GHC/IO/Device.hs"
, "base/GHC/IO/Encoding.hs"
, "base/GHC/IO/Encoding/CodePage.hs"
, "base/GHC/IO/Encoding/Failure.hs"
, "base/GHC/IO/Encoding/Iconv.hs"
, "base/GHC/IO/Encoding/Latin1.hs"
, "base/GHC/IO/Encoding/Types.hs"
, "base/GHC/IO/Encoding/UTF16.hs"
, "base/GHC/IO/Encoding/UTF32.hs"
, "base/GHC/IO/Encoding/UTF8.hs"
, "base/GHC/IO/Exception.hs"
, "base/GHC/IO/FD.hs"
, "base/GHC/IO/Handle.hs"
, "base/GHC/IO/Handle/FD.hs"
, "base/GHC/IO/Handle/Internals.hs"
, "base/GHC/IO/Handle/Text.hs"
, "base/GHC/IO/Handle/Types.hs"
, "base/GHC/IO/IOMode.hs"
, "base/GHC/IO/Unsafe.hs"
, "base/GHC/IOArray.hs"
, "base/GHC/IORef.hs"
, "base/GHC/Int.hs"
, "base/GHC/List.hs"
, "base/GHC/MVar.hs"
, "base/GHC/Natural.hs"
, "base/GHC/Num.hs"
, "base/GHC/OldList.hs"
, "base/GHC/OverloadedLabels.hs"
, "base/GHC/PArr.hs"
, "base/GHC/Pack.hs"
, "base/GHC/Profiling.hs"
, "base/GHC/Ptr.hs"
, "base/GHC/Read.hs"
, "base/GHC/Real.hs"
, "base/GHC/RTS/Flags.hs"
, "base/GHC/ST.hs"
, "base/GHC/StaticPtr.hs"
, "base/GHC/STRef.hs"
, "base/GHC/Show.hs"
, "base/GHC/Stable.hs"
, "base/GHC/Stack.hs"
, "base/GHC/Stack/CCS.hs"
, "base/GHC/Stack/Types.hs"
, "base/GHC/Stats.hs"
, "base/GHC/Storable.hs"
, "base/GHC/TopHandler.hs"
, "base/GHC/TypeLits.hs"
, "base/GHC/Unicode.hs"
, "base/GHC/Weak.hs"
, "base/GHC/Word.hs"
, "base/Numeric.hs"
, "base/Numeric/Natural.hs"
, "base/Prelude.hs"
, "base/System/CPUTime.hs"
, "base/System/Console/GetOpt.hs"
, "base/System/Environment.hs"
, "base/System/Exit.hs"
, "base/System/IO.hs"
, "base/System/IO/Error.hs"
, "base/System/IO/Unsafe.hs"
, "base/System/Info.hs"
, "base/System/Mem.hs"
, "base/System/Mem/StableName.hs"
, "base/System/Mem/Weak.hs"
, "base/System/Posix/Internals.hs"
, "base/System/Posix/Types.hs"
, "base/System/Timeout.hs"
, "base/Text/ParserCombinators/ReadP.hs"
, "base/Text/ParserCombinators/ReadPrec.hs"
, "base/Text/Printf.hs"
, "base/Text/Read.hs"
, "base/Text/Read/Lex.hs"
, "base/Text/Show.hs"
, "base/Text/Show/Functions.hs"
, "base/Unsafe/Coerce.hs"
]
-- printResult :: CompResult String -> IO ()
-- printResult result = do putStrLn errors
......
Simon Marlow <marlowsd@gmail.com>, simonmar, simonmar@microsoft.com
Ross Paterson <ross@soi.city.ac.uk>, ross
Sven Panne <sven.panne@aedion.de>, panne
Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>, malcolm
Simon Peyton Jones <simonpj@microsoft.com>, simonpj
Don Stewart <dons@galois.com>, dons
Tim Harris <tharris@microsoft.com>, tharris
Lennart Augustsson <lennart@augustsson.net>, lennart.augustsson@credit-suisse.com
Duncan Coutts <duncan@haskell.org>, duncan.coutts@worc.ox.ac.uk, duncan@well-typed.com
Ben Lippmeier <benl@ouroborus.net>, benl@cse.unsw.edu.au, Ben.Lippmeier@anu.edu.au
Manuel M T Chakravarty <chak@cse.unsw.edu.au>, chak
Jose Pedro Magalhaes <jpm@cs.uu.nl>, jpm@cs.uu.nl
*.o
*.aux
*.hi
*.tix
*.exe
# Backup files
*~
# Specific generated files
/GNUmakefile
/autom4te.cache/
/base.buildinfo
/config.log
/config.status
/configure
/dist-install/
/ghc.mk
/include/EventConfig.h
/include/HsBaseConfig.h
/include/HsBaseConfig.h.in
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Applicative
-- Copyright : Conor McBride and Ross Paterson 2005
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- This module describes a structure intermediate between a functor and
-- a monad (technically, a strong lax monoidal functor). Compared with
-- monads, this interface lacks the full power of the binding operation
-- '>>=', but
--
-- * it has more instances.
--
-- * it is sufficient for many uses, e.g. context-free parsing, or the
-- 'Data.Traversable.Traversable' class.
--
-- * instances can perform analysis of computations before they are
-- executed, and thus produce shared optimizations.
--
-- This interface was introduced for parsers by Niklas R&#xF6;jemo, because
-- it admits more sharing than the monadic interface. The names here are
-- mostly based on parsing work by Doaitse Swierstra.
--
-- For more details, see
-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>,
-- by Conor McBride and Ross Paterson.
module Control.Applicative (
-- * Applicative functors
Applicative(..),
-- * Alternatives
Alternative(..),
-- * Instances
Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..),
-- * Utility functions
(<$>), (<$), (<**>),
liftA, liftA2, liftA3,
optional,
) where
import Control.Category hiding ((.), id)
import Control.Arrow
import Data.Maybe
import Data.Tuple
import Data.Eq
import Data.Ord
import Data.Foldable (Foldable(..))
import Data.Functor ((<$>))
import Data.Functor.Const (Const(..))
import GHC.Base
import GHC.Generics
import GHC.List (repeat, zipWith)
import GHC.Read (Read)
import GHC.Show (Show)
newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a }
deriving (Generic, Generic1, Monad)
instance Monad m => Functor (WrappedMonad m) where
fmap f (WrapMonad v) = WrapMonad (liftM f v)
instance Monad m => Applicative (WrappedMonad m) where
pure = WrapMonad . pure
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 }
deriving (Generic, Generic1)
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] }
deriving ( Show, Eq, Ord, Read, Functor
, Foldable, Generic, Generic1)
-- See Data.Traversable for Traversabel instance due to import loops
instance Applicative ZipList where
pure x = ZipList (repeat x)
ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
-- extra functions
-- | One or none.
optional :: Alternative f => f a -> f (Maybe a)
optional v = Just <$> v <|> pure Nothing
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
-- The RULES for the methods of class Arrow may never fire
-- e.g. compose/arr; see Trac #10528
-----------------------------------------------------------------------------
-- |
-- Module : Control.Arrow
-- Copyright : (c) Ross Paterson 2002
-- License : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer : libraries@haskell.org
-- Stability : provisional
-- 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.
--
-- 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,
(^>>), (>>^),
(>>>), (<<<), -- reexported
-- ** Right-to-left variants
(<<^), (^<<),
-- * Monoid operations
ArrowZero(..), ArrowPlus(..),
-- * Conditionals
ArrowChoice(..),
-- * Arrow application
ArrowApply(..), ArrowMonad(..), leftApp,
-- * Feedback
ArrowLoop(..)
) where
import Data.Tuple ( fst, snd, uncurry )
import Data.Either
import Control.Monad.Fix
import Control.Category
import GHC.Base hiding ( (.), id )
infixr 5 <+>
infixr 3 ***
infixr 3 &&&
infixr 2 +++
infixr 2 |||
infixr 1 ^>>, >>^
infixr 1 ^<<, <<^
-- | The basic arrow class.
--
-- Instances should satisfy the following laws:
--
-- * @'arr' id = 'id'@
--
-- * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@
--
-- * @'first' ('arr' f) = 'arr' ('first' f)@
--
-- * @'first' (f >>> g) = 'first' f >>> 'first' g@
--
-- * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@
--
-- * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@
--
-- * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@
--
-- where
--
-- > assoc ((a,b),c) = (a,(b,c))
--
-- The other combinators have sensible default definitions,
-- which may be overridden for efficiency.
class Category a => Arrow a where
{-# MINIMAL arr, (first | (***)) #-}
-- | Lift a function to an arrow.
arr :: (b -> c) -> a b c
-- | 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)
first = (*** id)
-- | 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 = (id ***)
-- | 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 >>> arr swap >>> first g >>> arr swap
where swap ~(x,y) = (y,x)
-- | 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
"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
-- (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 (\_ -> mzero)
-- | A monoid on arrows.
class ArrowZero a => ArrowPlus a where
-- | An associative operation with identity 'zeroArrow'.
(<+>) :: a b c -> a b c -> a b c
instance MonadPlus m => ArrowPlus (Kleisli m