Commit b84b5969 authored by chevalier@alum.wellesley.edu's avatar chevalier@alum.wellesley.edu
Browse files

Cabalize ext-core tools

I cabalized the ext-core tools, so now they can be built as
a library. The driver program has to be built separately.

Also updated genprimopcode to reflect the new module hierarchy
for the Core tools.
parent 70f16d3f
{-# OPTIONS -Wall #-}
{- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
GHC standard Prelude modules and an application module called Main.
......@@ -17,15 +16,14 @@ import System.Environment
import System.Exit
import System.FilePath
import Core
import Dependencies
import Overrides
import Prims
import Check
import Prep
import Interp
import ParsecParser
import Language.Core.Core
import Language.Core.Dependencies
import Language.Core.Overrides
import Language.Core.Prims
import Language.Core.Check
import Language.Core.Prep
import Language.Core.Interp
import Language.Core.ParsecParser
-- You may need to change this.
baseDir :: FilePath
......@@ -57,8 +55,8 @@ options =
Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
]
process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
-> IO (Check.Menv,[Module])
process :: Bool -> (Menv,[Module]) -> (FilePath, Module)
-> IO (Menv,[Module])
process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
-- if it's a library and we set typecheckLibs to False:
-- prep, but don't typecheck
......@@ -84,7 +82,7 @@ process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
++ " while processing " ++ f)
return (senv, modules)
prepM :: Check.Menv -> Module -> FilePath -> IO Module
prepM :: Menv -> Module -> FilePath -> IO Module
prepM senv' m _f = do
let m' = prepModule senv' m
--writeFile (f </> ".prepped") (show m')
......
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module Check(
module Language.Core.Check(
checkModule, envsModule,
checkExpr, checkType,
primCoercionError,
Menv, Venv, Tvenv, Envs(..),
CheckRes(..), splitTy, substl) where
import Maybe
import Control.Monad.Reader
import Language.Core.Core
import Language.Core.Printer()
import Language.Core.PrimEnv
import Language.Core.Env
import Core
import Printer()
import List
import Env
import PrimEnv
import Control.Monad.Reader
import Data.List
import Data.Maybe
{- Checking is done in a simple error monad. In addition to
allowing errors to be captured, this makes it easy to guarantee
......
module Core where
{-# OPTIONS -fno-warn-missing-signatures #-}
module Language.Core.Core where
import Encoding
import Language.Core.Encoding
import Data.Generics
import List (elemIndex)
import Data.List (elemIndex)
data Module
= Module AnMname [Tdef] [Vdefg]
......@@ -162,22 +163,25 @@ splitTyConApp_maybe (Tapp rator rand) =
Nothing -> case rator of
Tcon tc -> Just (tc,[rand])
_ -> Nothing
splitTyConApp_maybe t@(Tforall _ _) = Nothing
splitTyConApp_maybe (Tforall _ _) = Nothing
-- coercions
splitTyConApp_maybe _ = Nothing
-- This used to be called nearlyEqualTy, but now that
-- we don't need to expand newtypes anymore, it seems
-- like equality to me!
equalTy :: Ty -> Ty -> Bool
equalTy t1 t2 = eqTy [] [] t1 t2
where eqTy e1 e2 (Tvar v1) (Tvar v2) =
case (elemIndex v1 e1,elemIndex v2 e2) of
(Just i1, Just i2) -> i1 == i2
(Nothing, Nothing) -> v1 == v2
_ -> False
eqTy e1 e2 (Tcon c1) (Tcon c2) = c1 == c2
eqTy _ _ (Tcon c1) (Tcon c2) = c1 == c2
eqTy e1 e2 (Tapp t1a t1b) (Tapp t2a t2b) =
eqTy e1 e2 t1a t2a && eqTy e1 e2 t1b t2b
eqTy e1 e2 (Tforall (tv1,tk1) t1) (Tforall (tv2,tk2) t2) =
tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) t1 t2
eqTy e1 e2 (Tforall (tv1,tk1) b1) (Tforall (tv2,tk2) b2) =
tk1 `eqKind` tk2 && eqTy (tv1:e1) (tv2:e2) b1 b2
eqTy _ _ _ _ = False
instance Eq Ty where (==) = equalTy
......
{-# OPTIONS -Wall #-}
module Dependencies(getDependencies) where
module Language.Core.Dependencies(getDependencies) where
import Core
import Encoding
import ParsecParser
import Language.Core.Core
import Language.Core.Encoding
import Language.Core.ParsecParser
import Control.Monad.State
import Data.Generics
......
{-# OPTIONS -Wall #-}
{- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
GHC standard Prelude modules and an application module called Main.
Note that, if compiled under GHC, this requires a very large heap to run!
-}
import Control.Exception
import Data.List
import Data.Maybe
import Monad
import Prelude hiding (catch)
import System.Cmd
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.FilePath
import Language.Core.Core
import Language.Core.Dependencies
import Language.Core.Overrides
import Language.Core.Prims
import Language.Core.Check
import Language.Core.Prep
import Language.Core.Interp
import Language.Core.ParsecParser
-- You may need to change this.
baseDir :: FilePath
baseDir = "../../libraries/"
-- change to True to typecheck library files as well as reading type signatures
typecheckLibs :: Bool
typecheckLibs = False
-- You shouldn't *need* to change anything below this line...
-- Code to check that the external and GHC printers print the same results
validateResults :: FilePath -> Module -> IO ()
validateResults origFile m = do
let genFile = origFile </> "parsed"
writeFile genFile (show m)
resultCode <- system $ "diff -u " ++ origFile ++ " " ++ genFile
putStrLn $ case resultCode of
ExitSuccess -> "Parse validated for " ++ origFile
ExitFailure 1 -> "Parse failed to validate for " ++ origFile
_ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
------------------------------------------------------------------------------
data Flag = Test | NoDeps
deriving Eq
options :: [OptDescr Flag]
options =
[Option ['t'] ["test"] (NoArg Test) "validate prettyprinted code",
Option ['n'] ["no-deps"] (NoArg NoDeps) "don't compute dependencies automatically"
]
process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
-> IO (Check.Menv,[Module])
process _ (senv,modules) p@(f,m) | isLib p && not typecheckLibs = do
-- if it's a library and we set typecheckLibs to False:
-- prep, but don't typecheck
m' <- prepM senv m f
return (senv, modules ++ [m'])
where isLib (fp,_) = baseDir `isPrefixOf` fp
process doTest (senv,modules) (f, m@(Module mn _ _)) = catch (do
when doTest $ validateResults f m
(case checkModule senv m of
OkC senv' ->
do putStrLn $ "Check succeeded for " ++ show mn
m' <- prepM senv' m f
case checkModule senv' m' of
OkC senv'' ->
do putStrLn "Recheck succeeded"
return (senv'',modules ++ [m'])
FailC s ->
do putStrLn ("Recheck failed: " ++ s)
error "quit"
FailC s -> error ("Typechecking failed: " ++ s))) handler
where handler e = do
putStrLn ("WARNING: we caught an exception " ++ show e
++ " while processing " ++ f)
return (senv, modules)
prepM :: Check.Menv -> Module -> FilePath -> IO Module
prepM senv' m _f = do
let m' = prepModule senv' m
--writeFile (f </> ".prepped") (show m')
return m'
main :: IO ()
main = do
args <- getArgs
case getOpt Permute options args of
(opts, fnames@(_:_), _) ->
let doTest = Test `elem` opts
computeDeps = NoDeps `notElem` opts in
doOneProgram computeDeps doTest fnames
_ -> error "usage: ./Driver [filename]"
where doOneProgram :: Bool -> Bool -> [FilePath] -> IO ()
doOneProgram computeDeps doTest fns = do
putStrLn $ "========== Program " ++ (show fns) ++ " ============="
deps <- if computeDeps
then
getDependencies fns
else (liftM catMaybes) (mapM findModuleDirect fns)
putStrLn $ "deps = " ++ show (fst (unzip deps))
{-
Note that we scan over the libraries twice:
first to gather together all type sigs, then to typecheck them
(the latter of which doesn't necessarily have to be done every time.)
This is a hack to avoid dealing with circular dependencies.
-}
-- notice: scan over libraries *and* input modules first, not just libs
topEnv <- mkInitialEnv (snd (unzip deps))
(_,modules) <- foldM (process doTest) (topEnv,[]) deps
let succeeded = length modules
putStrLn ("Finished typechecking. Successfully checked "
++ show succeeded)
overridden <- override modules
result <- evalProgram overridden
putStrLn ("Result = " ++ show result)
putStrLn "All done\n============================================="
mkInitialEnv :: [Module] -> IO Menv
mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
mkTypeEnv :: Menv -> Module -> IO Menv
mkTypeEnv globalEnv m@(Module mn _ _) =
catch (return (envsModule globalEnv m)) handler
where handler e = do
putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
++ " while processing " ++ show mn)
return globalEnv
findModuleDirect :: FilePath -> IO (Maybe (FilePath, Module))
-- kludge to let us run "make libtest" --
-- this module (in the Cabal package) causes an uncaught exception
-- from Prelude.chr, which I haven't been able to track down
findModuleDirect fn | "PackageDescription.hcr" `isSuffixOf` fn = return Nothing
findModuleDirect fn = do
putStrLn $ "Finding " ++ show fn
res <- parseCore fn
case res of
Left err -> error (show err)
Right m -> return $ Just (fn,m)
\ No newline at end of file
module Encoding where
{-# OPTIONS -fno-warn-name-shadowing #-}
module Language.Core.Encoding where
import Data.Char
import Numeric
......
......@@ -3,7 +3,7 @@
Sadly it doesn't seem to matter much. --tjc
-}
module Env (Env,
module Language.Core.Env (Env,
eempty,
elookup,
eextend,
......@@ -15,7 +15,6 @@ module Env (Env,
where
import qualified Data.Map as M
import Data.List
data Env a b = Env (M.Map a b)
deriving Show
......@@ -45,5 +44,5 @@ eremove :: (Eq a, Ord a) => Env a b -> a -> Env a b
eremove (Env l) k = Env (M.delete k l)
efilter :: Ord a => Env a b -> (a -> Bool) -> Env a b
efilter (Env l) p = Env (M.filterWithKey (\ k a -> p k) l)
efilter (Env l) p = Env (M.filterWithKey (\ k _ -> p k) l)
{-# OPTIONS -Wall -fno-warn-name-shadowing -XPatternGuards #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing -XPatternGuards -fglasgow-exts #-}
{-
Interprets the subset of well-typed Core programs for which
(a) All constructor and primop applications are saturated
......@@ -15,7 +15,7 @@ The only major omission is garbage collection.
Just a sampling of primitive types and operators are included.
-}
module Interp ( evalProgram ) where
module Language.Core.Interp ( evalProgram ) where
import Control.Monad.Error
import Control.Monad.State
......@@ -25,9 +25,9 @@ import Data.List
import GHC.Exts hiding (Ptr)
import System.IO
import Core
import Env
import Printer()
import Language.Core.Core
import Language.Core.Env
import Language.Core.Printer()
data HeapValue =
Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
......
......@@ -11,12 +11,12 @@
It's kind of ugly.
-}
module Overrides (override) where
module Language.Core.Overrides (override) where
import Core
import Encoding
import ParsecParser
import Prims
import Language.Core.Core
import Language.Core.Encoding
import Language.Core.ParsecParser
import Language.Core.Prims
import Data.Generics
import System.FilePath
......
module ParseGlue where
module Language.Core.ParseGlue where
import Encoding
......@@ -60,28 +60,3 @@ data Token =
| TKstring String
| TKchar Char
| TKEOF
-- ugh
splitModuleName mn =
let decoded = zDecodeString mn
-- Triple ugh.
-- We re-encode the individual parts so that:
-- main:Foo_Bar.Quux.baz
-- prints as:
-- main:FoozuBarziQuux.baz
-- and not:
-- main:Foo_BarziQuux.baz
parts = map zEncodeString $ filter (notElem '.') $ groupBy
(\ c1 c2 -> c1 /= '.' && c2 /= '.')
decoded in
(take (length parts - 1) parts, last parts)
{-# OPTIONS -Wall -fno-warn-missing-signatures #-}
module ParsecParser (parseCore) where
module Language.Core.ParsecParser (parseCore) where
import Core
import ParseGlue
import Check
import PrimCoercions
import Language.Core.Core
import Language.Core.Check
import Language.Core.Encoding
import Language.Core.PrimCoercions
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Data.Char
import Data.List
import Data.Ratio
parseCore :: FilePath -> IO (Either ParseError Module)
......@@ -491,6 +492,21 @@ defaultAlt = do
rhs <- coreFullExp
return $ Adefault rhs
----------------
-- ugh
splitModuleName mn =
let decoded = zDecodeString mn
-- Triple ugh.
-- We re-encode the individual parts so that:
-- main:Foo_Bar.Quux.baz
-- prints as:
-- main:FoozuBarziQuux.baz
-- and not:
-- main:Foo_BarziQuux.baz
parts = map zEncodeString $ filter (notElem '.') $ groupBy
(\ c1 c2 -> c1 /= '.' && c2 /= '.')
decoded in
(take (length parts - 1) parts, last parts)
----------------
extCore = P.makeTokenParser extCoreDef
parens = P.parens extCore
......
......@@ -9,17 +9,16 @@ After these preprocessing steps, Core can be interpreted (or given an operationa
-}
module Prep where
module Language.Core.Prep where
import Data.Either
import Prims
import Core
import Env
import Check
import Data.List
import Language.Core.Prims
import Language.Core.Core
import Language.Core.Env
import Language.Core.Check
prepModule :: Menv -> Module -> Module
prepModule globalEnv (Module mn tdefs vdefgs) =
Module mn tdefs vdefgs'
......
{-# OPTIONS -Wall -fno-warn-missing-signatures #-}
module PrimCoercions where
import Core
module Language.Core.PrimCoercions where
import Language.Core.Core
-- Stuff the parser needs to know about
......
This diff is collapsed.
......@@ -4,15 +4,14 @@
Most are defined in PrimEnv, which is automatically generated from
GHC's primops.txt. -}
module Prims(initialEnv, primEnv, newPrimVars) where
import Core
import Encoding
import Env
import Check
import PrimCoercions
import PrimEnv
module Language.Core.Prims(initialEnv, primEnv, newPrimVars) where
import Language.Core.Core
import Language.Core.Encoding
import Language.Core.Env
import Language.Core.Check
import Language.Core.PrimCoercions
import Language.Core.PrimEnv
initialEnv :: Menv
initialEnv = efromlist [(primMname,primEnv),
......
{-# OPTIONS -Werror -Wall -fno-warn-missing-signatures #-}
module Printer where
module Language.Core.Printer where
import Text.PrettyPrint.HughesPJ
import Char
import Data.Char
import Core
import Encoding
import PrimCoercions
import Language.Core.Core
import Language.Core.Encoding
import Language.Core.PrimCoercions
instance Show Module where
showsPrec _ m = shows (pmodule m)
......
all: extcorelibs Check.hs Core.hs Driver.hs Env.hs Interp.hs ParsecParser.hs ParseGlue.hs Prep.hs PrimCoercions.hs Prims.hs Printer.hs
ghc -O2 --make -fglasgow-exts -o Driver Driver.hs
extcorelibs:
$(MAKE) -C lib/GHC_ExtCore
# Run this when the primops.txt file changes
prims: ../../compiler/prelude/primops.txt
../genprimopcode/genprimopcode --make-ext-core-source < ../../compiler/prelude/primops.txt > PrimEnv.hs
#Parser.hs: Parser.y
# happy -ad -ihappy.debug -o Parser.hs Parser.y
# This makefile is just for running the tests. For everything else,
# use Cabal! (The tests could be run with Cabal too, I'm just too lazy
# to figure out how.)
# The following assumes that you've built all the GHC libs with -fext-core...
libtest: all
libtest:
./Driver -n `find ../../libraries -print | grep .hcr$$ | grep -v bootstrapping`
# ...or built all the nofib programs with -fext-core.
nofibtest: all
nofibtest:
./Driver `find ../../nofib -print | grep .hcr$$`
clean:
rm -f Driver *.hi *.o
reallyclean: clean
rm PrimEnv.hs
\ No newline at end of file
......@@ -54,11 +54,20 @@ running "make" under libraries/.
Then you need to edit Driver.hs and change "baseDir" to point to your GHC
libraries directory.
Once you've done that:
1. make prims (to generate the primops file)
2. make
3. make nofibtest (to run the parser/checker on all nofib programs...
Once you've done that, the ext-core library can be built in the usual
Cabal manner:
1. runhaskell Setup.lhs configure
2. runhaskell Setup.lhs build
3. runhaskell Setup.lhs install
Then, you can build the example Driver program with:
ghc -package extcore Driver.hs -o Driver
And finally, you can use the included Makefile to run tests:
make nofibtest (to run the parser/checker on all nofib programs...
for example.)
make libtest (to typecheck all the libraries)
Tested with GHC 6.8.2. I make no claims of portability.
......
#!/usr/bin/env runhaskell
\begin{code}
{-# OPTIONS -Wall #-}
import Control.Monad
import Data.List
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import System.Cmd
import System.FilePath
import System.Exit
import System.Directory
import Control.Exception (try)
main :: IO ()
main = do
let hooks = defaultUserHooks {
buildHook = build_primitive_sources
$ buildHook defaultUserHooks
}
defaultMainWithHooks hooks
\end{code}
Mostly snarfed from ghc-prim's Setup.hs.