The External Core interpreter works (in a limited sense).
For details, see the README.
This means we now have a marginally functioning set of
External Core tools.
The other exciting change is that the test driver (Driver.hs)
now computes module dependencies automatically instead of
having a wired-in list of library modules.
vdefIsMainWrapper :: AnMname -> Mname -> Bool
vdefIsMainWrapper enclosing defining =
- enclosing == mainMname && defining == wrapperMainMname
+ enclosing == mainMname && defining == wrapperMainAnMname
checkExpr :: AnMname -> Menv -> [Tdef] -> Venv -> Tvenv
-> Exp -> Ty
import Encoding
+import Data.Generics
import List (elemIndex)
data Module
= Module AnMname [Tdef] [Vdefg]
+ deriving (Data, Typeable)
data Tdef
= Data (Qual Tcon) [Tbind] [Cdef]
-- there is an implicit axiom:
-- co tbs :: tc tbs :=: t
| Newtype (Qual Tcon) (Qual Tcon) [Tbind] (Maybe Ty)
+ deriving (Data, Typeable)
data Cdef
= Constr (Qual Dcon) [Tbind] [Ty]
+ deriving (Data, Typeable)
data Vdefg
= Rec [Vdef]
| Nonrec Vdef
+ deriving (Data, Typeable)
newtype Vdef = Vdef (Qual Var,Ty,Exp)
+ deriving (Data, Typeable)
data Exp
= Var (Qual Var)
| Cast Exp Ty
| Note String Exp
| External String Ty
+ deriving (Data, Typeable)
data Bind
= Vb Vbind
| Tb Tbind
+ deriving (Data, Typeable)
data Alt
= Acon (Qual Dcon) [Tbind] [Vbind] Exp
| Alit Lit Exp
| Adefault Exp
+ deriving (Data, Typeable)
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
| InstCoercion Ty Ty
| LeftCoercion Ty
| RightCoercion Ty
+ deriving (Data, Typeable)
data Kind
= Klifted
| Kopen
| Karrow Kind Kind
| Keq Ty Ty
+ deriving (Data, Typeable)
-- A CoercionKind isn't really a Kind at all, but rather,
-- corresponds to an arbitrary user-declared axiom.
data KindOrCoercion = Kind Kind | Coercion CoercionKind
data Lit = Literal CoreLit Ty
- deriving Eq -- with nearlyEqualTy
+ deriving (Data, Typeable, Eq) -- with nearlyEqualTy
data CoreLit = Lint Integer
| Lrational Rational
| Lchar Char
| Lstring String
- deriving Eq
+ deriving (Data, Typeable, Eq)
-- Right now we represent module names as triples:
-- (package name, hierarchical names, leaf name)
type Mname = Maybe AnMname
newtype AnMname = M (Pname, [Id], Id)
- deriving (Eq, Ord)
-type Pname = Id
+ deriving (Eq, Ord, Data, Typeable)
+newtype Pname = P Id
+ deriving (Eq, Ord, Data, Typeable)
type Var = Id
type Tvar = Id
type Tcon = Id
unqual :: t -> Qual t
unqual = (,) Nothing
+getModule :: Qual t -> Mname
+getModule = fst
+
type Id = String
eqKind :: Kind -> Kind -> Bool
mkBaseMname,mkPrimMname :: Id -> AnMname
mkBaseMname mn = M (basePkg, ghcPrefix, mn)
mkPrimMname mn = M (primPkg, ghcPrefix, mn)
-basePkg = "base"
-mainPkg = "main"
-primPkg = zEncodeString "ghc-prim"
+basePkg = P "base"
+mainPkg = P "main"
+primPkg = P $ zEncodeString "ghc-prim"
ghcPrefix = ["GHC"]
mainPrefix = []
baseMname = mkBaseMname "Base"
boolMname = mkPrimMname "Bool"
mainVar = qual mainMname "main"
+wrapperMainVar = qual wrapperMainMname "main"
mainMname = M (mainPkg, mainPrefix, "Main")
-wrapperMainMname = Just $ M (mainPkg, mainPrefix, "ZCMain")
+wrapperMainMname = M (mainPkg, mainPrefix, "ZCMain")
+wrapperMainAnMname = Just wrapperMainMname
+
+dcTrue :: Dcon
+dcTrue = "True"
+dcFalse :: Dcon
+dcFalse = "False"
tcArrow :: Qual Tcon
tcArrow = (Just primMname, "ZLzmzgZR")
tArrow :: Ty -> Ty -> Ty
tArrow t1 t2 = Tapp (Tapp (Tcon tcArrow) t1) t2
+mkFunTy :: Ty -> Ty -> Ty
+mkFunTy randTy resultTy =
+ Tapp (Tapp (Tcon tcArrow) randTy) resultTy
ktArrow :: Kind
ktArrow = Karrow Kopen (Karrow Kopen Klifted)
utuple :: [Ty] -> [Exp] -> Exp
utuple ts es = foldl App (foldl Appt (Dcon (dcUtuple (length es))) ts) es
-
+---- snarfed from GHC's CoreSyn
+flattenBinds :: [Vdefg] -> [Vdef] -- Get all the lhs/rhs pairs
+flattenBinds (Nonrec vd : binds) = vd : flattenBinds binds
+flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
+flattenBinds [] = []
--- /dev/null
+{-# OPTIONS -Wall #-}
+{-
+ Besides computing dependencies between External Core modules,
+ this module encapsulates some magic regarding overridden modules.
+
+ In the interpreter, we use "overridden" versions of certain
+ standard GHC library modules in order to avoid implementing
+ more primitives than we need to implement to run simple programs.
+ So, during the dependency-finding process (which, because the
+ dependency-finder maintains a module cache to make sure no
+ module is loaded/parsed more than once), references to overridden
+ modules are resolved to references to modules in our simplified
+ version of the standard library.
+
+ It's kind of ugly.
+-}
+module Dependencies(getDependencies) where
+
+import Core
+import Encoding
+import ParsecParser
+import Prims
+
+import Control.Monad.State
+import Data.Generics
+import Data.List
+import qualified Data.Map as M
+import Data.Maybe
+import System.Directory
+import System.FilePath
+import System.IO
+
+type DepM a = StateT (FilePath, -- "main" module file path
+ -- maps module names onto dependencies
+ M.Map (Either AnMname FilePath) [AnMname],
+ -- module cache
+ M.Map (Either AnMname FilePath) (FilePath, Module)) IO a
+
+-- Given a module, return all the modules it
+-- depends on (directly or indirectly).
+getDependencies :: [FilePath] -> IO [(FilePath, Module)]
+getDependencies ms =
+ evalStateT (do
+ (mapM_ (\ f -> do
+ liftIO $ putStrLn $ "==== Finding deps for " ++ show f ++ "====="
+ -- Every module depends on itself anyway,
+ -- so we ignore the FilePath deps.
+ ds <- go getDeps lefts (map Left) (map Right ms)
+ return (f, ds)) ms)
+ (_,t,_) <- get
+ let modNames = nub $ concat (snd (unzip (leftsPairs (M.toList t))))
+ (liftM catMaybes) $ mapM findModuleP (map Left modNames))
+ (last ms, M.empty, M.empty)
+
+go :: (Show a, Show b, Eq b, MonadIO m) =>
+ (a -> m [b]) -> ([a] -> [b]) -> ([b] -> [a]) -> [a] -> m [b]
+go getMore p fixUp start = do
+ next <- concatMapM getMore start
+ let more = nub $ (p start) ++ next
+ if (length start == length more)
+ then return more
+ else go getMore p fixUp (fixUp more)
+
+varRef :: Exp -> [AnMname]
+varRef (Var v) | Just m' <- getModule v = [m']
+varRef (Dcon dc) | Just m' <- getModule dc = [m']
+varRef _ = []
+
+tyRef :: Ty -> [AnMname]
+tyRef (Tcon tc) | Just m' <- getModule tc = [m']
+tyRef _ = []
+
+
+getDeps :: Either AnMname FilePath -> DepM [AnMname]
+getDeps mn = do
+ (a,t,b) <- get
+ case M.lookup mn t of
+ Just ds -> return ds
+ Nothing -> do
+ maybeM <- findModule mn
+ case maybeM of
+ Nothing -> return []
+ Just m@(Module mname _ _) -> do
+ let ds = (everything union ([] `mkQ` varRef) m)
+ `union` (everything union ([] `mkQ` tyRef) m) in do
+ put (a, M.insert mn ds t, b)
+ -- in case we were given a filepath, register the
+ -- module name too
+ put (a, M.insert (Left mname) ds t, b)
+ return ds
+
+findModule :: Either AnMname FilePath -> DepM (Maybe Module)
+findModule x = do
+ maybeRes <- findModuleP x
+ case maybeRes of
+ Just (_,m) -> return $ Just m
+ _ -> return Nothing
+
+findModuleP :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
+findModuleP (Left mn) | mn `elem` wiredInModules =
+ findWiredInModule mn >>= (return . Just)
+findModuleP (Left mn) | mn == wrapperMainMname || mn == mainMname = do
+ (f,_,_) <- get
+ findModuleP (Right f)
+findModuleP (Left mn) | mn == primMname = return Nothing
+ -- Nothing means that this module is valid; it just doesn't have
+ -- an implementation
+findModuleP m = tryFindModule m
+
+tryFindModule :: Either AnMname FilePath -> DepM (Maybe (FilePath, Module))
+tryFindModule k = do
+ (_,_,mCache) <- get
+ liftM Just $ case M.lookup k mCache of
+ Just p -> return p
+ Nothing -> findModuleNotCached k
+
+-- This function encapsulates all the business with overriden modules.
+-- The story is that if an "overridden" module exists for the given
+-- module, then we parse it in and rewrite all occurrences of the "base-extcore"
+-- package name inside it to "base". We have to do this b/c when compiling
+-- the overridden modules, we gave the package name "base-extcore", because
+-- GHC gets unhappy if we try to make it part of the "base" package.
+-- Was that clear? (No.)
+findModuleNotCached :: Either AnMname FilePath -> DepM (FilePath, Module)
+findModuleNotCached (Left m@(M (P pkgName, encHier, encLeafName))) = do
+ let hier = map zDecodeString encHier
+ leafName = zDecodeString encLeafName
+ possibleFiles = (map (dirs hier leafName) searchPath)
+ ++ map (dirs (zDecodeString pkgName:hier) leafName) searchPath in do
+ match <- liftIO $ findM doesFileExist possibleFiles
+ case match of
+ Just fp -> findModule' Nothing fp
+ Nothing -> error ("findModule: failed to find dependency " ++ show m
+ ++ " tried " ++ show possibleFiles)
+findModuleNotCached (Right fp) = findModule' Nothing fp
+
+dirs :: [String] -> String -> FilePath -> FilePath
+dirs modulePath leafName dir = dir </>
+ (foldr (</>) (addExtension leafName "hcr") modulePath)
+
+findWiredInModule :: AnMname -> DepM (FilePath, Module)
+findWiredInModule m@(M (pn, encHier, encLeafName)) =
+ findModule' (Just munged) (wiredInFileName m)
+ where hier = map zDecodeString encHier
+ leafName = zDecodeString encLeafName
+ munged =
+ M (pn, map (\ p -> if p == "GHC_ExtCore" then "GHC" else p) hier,
+ leafName)
+
+findModule' :: Mname -> FilePath -> DepM (FilePath, Module)
+findModule' trueName fp = do
+ res <- liftIO $ parseCore fp
+ case res of
+ Left _ -> error ("findModule: error parsing dependency " ++ fp)
+ Right parsedMod -> do
+ let resultMod@(Module mn _ _) =
+ case trueName of
+ Just _ -> mungePackageName parsedMod
+ Nothing -> parsedMod
+ cacheModule mn fp resultMod
+ return (fp, resultMod)
+
+cacheModule :: AnMname -> FilePath -> Module -> DepM ()
+cacheModule mn fp m = modify (\ (a, b, cache) ->
+ (a, b, M.insert (Left mn) (fp, m)
+ (M.insert (Right fp) (fp, m)
+ cache)))
+
+searchPath :: [FilePath]
+searchPath = overriddenDir:["../../libraries/",
+ "../../libraries/integer-gmp/"]
+
+overriddenDir :: FilePath
+overriddenDir = "./lib/"
+
+findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
+findM p = liftM listToMaybe . filterM p
+
+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
+concatMapM f = (liftM concat) . (mapM f)
+
+lefts :: [Either a b] -> [a]
+lefts = foldr lefts' []
+ where lefts' (Left a) xs = a:xs
+ lefts' _ xs = xs
+
+leftsPairs :: [(Either a b, c)] -> [(a, c)]
+leftsPairs = foldr leftsPairs' []
+ where leftsPairs' ((Left x), y) xs = (x, y):xs
+ leftsPairs' _ xs = xs
+
+mungePackageName :: Module -> Module
+-- for now: just substitute "base-extcore" for "base"
+-- and "GHC" for "GHC_ExtCore" in every module name
+mungePackageName m@(Module mn _ _) = everywhere (mkT mungeMname)
+ (everywhere (mkT mungePname)
+ (everywhere (mkT mungeVarName) m))
+ where mungePname (P s) | s == zEncodeString overriddenPname =
+ (P "base")
+ mungePname p = p
+ -- rewrite uses of fake primops
+ mungeVarName (Var (Just mn', v))
+ | mn' == mn && v `elem` (fst (unzip newPrimVars)) =
+ Var (Just primMname, v)
+ mungeVarName e = e
+
+mungeMname :: AnMname -> AnMname
+mungeMname (M (pname, (hd:rest), leaf))
+ | zDecodeString hd == "GHC_ExtCore" =
+ (M (pname, ("GHC":rest), leaf))
+mungeMname mn = mn
+
+overriddenPname :: String
+overriddenPname = "base-extcore"
+
+wiredInModules :: [AnMname]
+wiredInModules =
+ map (\ m -> (mkBaseMname m)) ["Handle", "IO", "Unicode"]
+
+wiredInFileName :: AnMname -> FilePath
+wiredInFileName (M (_,_,leafName)) =
+ "./lib/GHC_ExtCore/" </> leafName `addExtension` "hcr"
+{-# OPTIONS -Wall #-}
+
{- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the
GHC standard Prelude modules and an application module called Main.
import Control.Exception
import Data.List
-import Maybe
import Monad
import Prelude hiding (catch)
import System.Cmd
import System.FilePath
import Core
-import Printer
-import ParsecParser
-import Env
+import Dependencies
import Prims
import Check
import Prep
import Interp
-- You may need to change this.
+baseDir :: FilePath
baseDir = "../../libraries/"
-- change to True to typecheck library files as well as reading type signatures
-typecheckLibs = False
+typecheckLibs :: Bool
+typecheckLibs = False
-- You shouldn't *need* to change anything below this line...
-libDir = map (baseDir ++)
-- Code to check that the external and GHC printers print the same results
+testFlag :: String
testFlag = "-t"
-
-validateResults :: FilePath -> FilePath -> IO ()
-validateResults origFile genFile = do
+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
_ -> "Error diffing files: " ++ origFile ++ " " ++ genFile
------------------------------------------------------------------------------
-process :: Bool -> (Check.Menv,[Module]) -> FilePath
+process :: Bool -> (Check.Menv,[Module]) -> (FilePath, Module)
-> IO (Check.Menv,[Module])
-process doTest (senv,modules) f = catch
- (do putStrLn ("Processing " ++ f)
- resultOrErr <- parseCore f
- case resultOrErr of
- Right m@(Module mn _ _) -> do
- putStrLn "Parse succeeded"
- let outF = f ++ ".parsed"
- writeFile outF (show m)
- when doTest $ (validateResults f outF)
- case checkModule senv m of
- OkC senv' ->
- do putStrLn $ "Check succeeded for " ++ show mn
- let m' = prepModule senv' m
- let (dir,fname) = splitFileName f
- let preppedFile = dir </> (fname ++ ".prepped")
- writeFile preppedFile (show m')
- 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)
- Left err -> error ("Parsing failed: " ++ show err)) handler
+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)
-main = do args <- getArgs
- let (doTest, fnames) =
- case args of
- (f:rest) | f == testFlag -> (True,rest)
- rest@(_:_) -> (False,rest)
- _ -> error $
- "usage: ./Driver [filename]"
- -- 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 (map normalise libs `union` map normalise fnames)
- doOneProgram doTest topEnv fnames
- where doOneProgram doTest topEnv fns = do
- putStrLn $ "========== Program " ++ (show fns) ++ " ================"
- let numToDo = length (typecheckLibraries fns)
- (_,modules) <- foldM (process doTest) (topEnv,[]) (typecheckLibraries fns)
- let succeeded = length modules
- putStrLn ("Finished typechecking. Successfully checked " ++ show succeeded
- ++ " out of " ++ show numToDo ++ " modules.")
- -- TODO: uncomment once interpreter works
- --let result = evalProgram modules
- --putStrLn ("Result = " ++ show result)
- putStrLn "All done\n============================================="
+prepM :: Check.Menv -> Module -> FilePath -> IO Module
+prepM senv' m _f = do
+ let m' = prepModule senv' m
+ --writeFile (f </> ".prepped") (show m')
+ return m'
- typecheckLibraries = if typecheckLibs then (libs ++) else id
- -- Just my guess as to what's needed from the base libs.
- -- May well be missing some libraries and have some that
- -- aren't commonly used.
- -- However, the following is enough to check all of nofib.
- -- This points to how nice it would be to have explicit import lists in ext-core.
- libs = (libDir ["./ghc-prim/GHC/Generics.hcr",
- "./ghc-prim/GHC/Bool.hcr",
- "./ghc-prim/GHC/IntWord64.hcr",
- "./base/GHC/Base.hcr",
- "./base/Data/Tuple.hcr",
- "./base/Data/Maybe.hcr",
- "./integer-gmp/GHC/Integer.hcr",
- "./base/GHC/List.hcr",
- "./base/GHC/Enum.hcr",
- "./base/Data/Ord.hcr",
- "./base/Data/String.hcr",
- "./base/Data/Either.hcr",
- "./base/GHC/Show.hcr",
- "./base/GHC/Num.hcr",
- "./base/GHC/ST.hcr",
- "./base/GHC/STRef.hcr",
- "./base/GHC/Arr.hcr",
- "./base/GHC/Real.hcr",
- "./base/Control/Monad.hcr",
- "./base/GHC/Int.hcr",
- "./base/GHC/Unicode.hcr",
- "./base/Text/ParserCombinators/ReadP.hcr",
- "./base/Text/Read/Lex.hcr",
- "./base/Text/ParserCombinators/ReadPrec.hcr",
- "./base/GHC/Read.hcr",
- "./base/GHC/Word.hcr",
- "./base/Data/HashTable.hcr",
- "./base/Unsafe/Coerce.hcr",
- "./base/Foreign/Storable.hcr",
- "./base/Foreign/C/Types.hcr",
- "./base/GHC/IOBase.hcr",
- "./base/GHC/ForeignPtr.hcr",
- "./base/Data/Typeable.hcr",
- "./base/Data/Dynamic.hcr",
- "./base/GHC/Err.hcr",
- "./base/Data/List.hcr",
- "./base/Data/Char.hcr",
- "./base/GHC/Pack.hcr",
- "./base/GHC/Storable.hcr",
- "./base/System/IO/Error.hcr",
- "./base/Foreign/Ptr.hcr",
- "./base/Foreign/Marshal/Error.hcr",
- "./base/Foreign/ForeignPtr.hcr",
- "./base/Foreign/Marshal/Alloc.hcr",
- "./base/Foreign/Marshal/Utils.hcr",
- "./base/Foreign/Marshal/Array.hcr",
- "./base/Foreign/C/String.hcr",
- "./base/Foreign/C/Error.hcr",
- "./base/Foreign/C.hcr",
- "./base/System/IO/Unsafe.hcr",
- "./base/Foreign/Marshal.hcr",
- "./base/Foreign/StablePtr.hcr",
- "./base/Foreign.hcr",
- "./base/System/Posix/Types.hcr",
- "./base/System/Posix/Internals.hcr",
- "./base/GHC/Conc.hcr",
- "./base/Control/Exception.hcr",
- "./base/GHC/TopHandler.hcr",
- "./base/Data/Bits.hcr",
- "./base/Numeric.hcr",
- "./base/GHC/Ptr.hcr",
- "./base/GHC/Float.hcr",
- "./base/GHC/Exception.hcr",
- "./base/GHC/Stable.hcr",
- "./base/GHC/Weak.hcr",
- "./base/GHC/Handle.hcr",
- "./base/GHC/IO.hcr",
- "./base/GHC/Dotnet.hcr",
- "./base/GHC/Environment.hcr",
- "./base/GHC/Exts.hcr",
- "./base/GHC/PArr.hcr",
- "./base/System/IO.hcr",
- "./base/System/Environment.hcr",
- "./base/Data/Generics/Basics.hcr",
- "./base/Data/Complex.hcr",
- "./array/Data/Array/Base.hcr",
- "./base/System/Exit.hcr",
- "./base/Data/Ratio.hcr",
- "./base/Control/Monad/ST/Lazy.hcr",
- "./base/Prelude.hcr",
- "./base/Control/Concurrent/MVar.hcr",
- "./base/Data/Foldable.hcr"])
+main :: IO ()
+main = do
+ args <- getArgs
+ let (doTest, fnames) =
+ case args of
+ (f:rest) | f == testFlag -> (True,rest)
+ rest@(_:_) -> (False,rest)
+ _ -> error "usage: ./Driver [filename]"
+ doOneProgram doTest fnames
+ where doOneProgram :: Bool -> [FilePath] -> IO ()
+ doOneProgram doTest fns = do
+ putStrLn $ "========== Program " ++ (show fns) ++ " ================"
+ deps <- getDependencies 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)
+ result <- evalProgram modules
+ putStrLn ("Result = " ++ show result)
+ putStrLn "All done\n============================================="
-mkInitialEnv :: [FilePath] -> IO Menv
-mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
+ mkInitialEnv :: [Module] -> IO Menv
+ mkInitialEnv libs = foldM mkTypeEnv initialEnv libs
-mkTypeEnv :: Menv -> FilePath -> IO Menv
-mkTypeEnv globalEnv fn = catch (do
- putStrLn $ "mkTypeEnv: reading library " ++ fn
- resultOrErr <- parseCore fn
- case resultOrErr of
- Right mod@(Module mn _ _) -> do
- let newE = envsModule globalEnv mod
- return newE
- Left err -> do putStrLn ("Failed to parse library module: " ++ show err)
- error "quit") handler
- where handler e = do
- putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e
- ++ " while processing " ++ fn)
- return globalEnv
+ 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
-{-# OPTIONS -XPatternGuards #-}
+{-# OPTIONS -Wall -fno-warn-name-shadowing -XPatternGuards #-}
{-
Interprets the subset of well-typed Core programs for which
(a) All constructor and primop applications are saturated
module Interp ( evalProgram ) where
+import Control.Monad.Error
+import Control.Monad.State
+import Data.Char
+import Data.List
+
+import GHC.Exts hiding (Ptr)
+import System.IO
+
import Core
-import Printer
-import Monad
import Env
-import List
-import Char
-import Prims
+import Printer()
data HeapValue =
Hconstr Dcon [Value] -- constructed value (note: no qualifier needed!)
| Vutuple [Value] -- unboxed tuples
deriving (Show)
+instance Error Value where
+ -- TODO: ??
+ strMsg s = error s
+
type Venv = Env Var Value -- values of vars
data PrimValue = -- values of the (unboxed) primitive types
| PFloatzh Rational -- actually 32-bit
| PDoublezh Rational -- actually 64-bit
-- etc., etc.
+ | PString String
deriving (Eq,Show)
type Menv = Env AnMname Venv -- modules
type Exn = Value
-newtype Eval a = Eval (Heap -> (Heap,Either a Exn))
-
-instance Monad Eval where
- (Eval m) >>= k = Eval (
- \h -> case m h of
- (h',Left x) -> case k x of
- Eval k' -> k' h'
- (h',Right exn) -> (h',Right exn))
- return x = Eval (\h -> (h,Left x))
+type Eval a = ErrorT Exn (StateT Heap IO) a
hallocateE :: HeapValue -> Eval Ptr
-hallocateE v = Eval (\ h ->
- let (h',p) = hallocate h v
- in (h', Left p))
+hallocateE v = do
+ h <- get
+ let (h', p) = hallocate h v
+ put h'
+ return p
hupdateE :: Ptr -> HeapValue -> Eval ()
-hupdateE p v = Eval (\h -> (hupdate h p v,Left ()))
+hupdateE p v = modify (\ h -> hupdate h p v)
hlookupE :: Ptr -> Eval HeapValue
-hlookupE p = Eval (\h -> (h,Left (hlookup h p)))
+hlookupE p = get >>= (\h -> return (hlookup h p))
hremoveE :: Ptr -> Eval ()
-hremoveE p = Eval (\h -> (hremove h p, Left ()))
+hremoveE p = modify (\h -> hremove h p)
raiseE :: Exn -> Eval a
-raiseE exn = Eval (\h -> (h,Right exn))
-
-catchE :: Eval a -> (Exn -> Eval a) -> Eval a
-catchE (Eval m) f = Eval
- (\h -> case m h of
- (h',Left x) -> (h',Left x)
- (h',Right exn) ->
- case f exn of
- Eval f' -> f' h')
+raiseE = throwError
-runE :: Eval a -> a
-runE (Eval f) =
- case f hempty of
- (_,Left v) -> v
- (_,Right exn) -> error ("evaluation failed with uncaught exception: " ++ show exn)
+catchE :: Show a => Eval a -> (Exn -> Eval a) -> Eval a
+catchE = catchError
+runE :: Eval a -> IO a
+runE m = do
+ resultOrError <- evalStateT (runErrorT m) hempty
+ case resultOrError of
+ Right v -> return v
+ Left exn -> error
+ ("evaluation failed with uncaught exception: " ++ show exn)
{- Main entry point -}
-evalProgram :: [Module] -> Value
-evalProgram modules =
- runE(
- do globalEnv <- foldM evalModule initialGlobalEnv modules
- Vutuple [_,v] <- evalExp globalEnv eempty (App (Var mainVar)
- (Var (qual primMname "realWorldzh")))
- return v)
+-- TODO: This is in the IO monad because primitive I/O ops
+-- actually perform the IO. It might be better to model it
+-- instead (by having the interpreter return a ([Char] -> (Value, [Char])))
+evalProgram :: [Module] -> IO Value
+evalProgram modules = runE $ do
+ -- We do two passes: one to slurp in all the definitions *except*
+ -- for :Main.main, and then one to look for the Main module
+ -- and extract out just the :Main.main defn.
+ -- It's kind of annoying.
+ globalEnv' <- foldM evalModule initialGlobalEnv modules
+ globalEnv <- evalModule globalEnv' (rootModule modules)
+ Vutuple [_,v] <- evalExp globalEnv eempty (App (Var wrapperMainVar)
+ stateToken)
+ return v
+
+rootModule :: [Module] -> Module
+-- This looks for the Main module, and constructs
+-- a fake module containing only the defn of
+-- :Main.main.
+rootModule ms =
+ case find (\ (Module mn _ _) -> mn == mainMname) ms of
+ Just (Module _ _ [Rec bs]) ->
+ Module wrapperMainMname []
+ [Rec (filter isWrapperMainVdef bs)]
+ _ -> error "eval: missing main module"
+ where isWrapperMainVdef (Vdef (v,_,_)) | v == wrapperMainVar = True
+ isWrapperMainVdef _ = False
{- Environments:
evalModule :: Menv -> Module -> Eval Menv
-evalModule globalEnv (Module mn tdefs vdefgs) =
- do (e_venv,l_venv) <- foldM evalVdef (eempty,eempty) vdefgs
+evalModule globalEnv (Module mn _ vdefgs) =
+ do (e_venv,_) <- foldM evalVdef (eempty,eempty) vdefgs
return (eextend globalEnv (mn,e_venv))
where
evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
- evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
+ evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),_,e))) =
do p <- hallocateE (suspendExp l_env e)
let heaps =
case m of
return heaps
evalVdef (e_env,l_env) (Rec vdefs) =
do l_vs0 <- mapM preallocate l_xs
- let l_env' = foldl eextend l_env (zip l_xs l_vs0)
+ let l_env' = foldl eextend l_env (zip l_xs (map Vheap l_vs0))
let l_hs = map (suspendExp l_env') l_es
mapM_ reallocate (zip l_vs0 l_hs)
let e_hs = map (suspendExp l_env') e_es
- e_vs <- mapM allocate e_hs
- let e_env' = foldl eextend e_env (zip e_xs e_vs)
+ e_vs <- (liftM (map Vheap)) $ mapM allocate e_hs
+ let e_env' = foldl eextend e_env (zip e_xs e_vs)
return (e_env',l_env')
where
(l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
- (e_xs,e_es) = unzip [(x,e) | Vdef((Just m,x),_,e) <- vdefs]
+ (e_xs,e_es) = unzip [(x,e) | Vdef ((Just _,x),_,e) <-
+ -- Do not dump the defn for :Main.main into
+ -- the environment for Main!
+ filter inHomeModule vdefs]
+ inHomeModule (Vdef ((Just m,_),_,_)) | m == mn = True
+ inHomeModule _ = False
preallocate _ =
do p <- hallocateE undefined
- return (Vheap p)
- reallocate (Vheap p0,h) =
+ return p
+ reallocate (p0,h) =
hupdateE p0 h
allocate h =
do p <- hallocateE h
- return (Vheap p)
+ return p
suspendExp:: Venv -> Exp -> HeapValue
suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
where env' = thin env (delete x (freevarsExp e))
suspendExp env e = Hthunk env' e
where env' = thin env (freevarsExp e)
-
evalExp :: Menv -> Venv -> Exp -> Eval Value
-evalExp globalEnv env (Var qv) =
- let v = qlookup globalEnv env qv
- in case v of
- Vheap p ->
- do z <- hlookupE p -- can fail due to black-holing
- case z of
- Hthunk env' e ->
- do hremoveE p -- black-hole
- w@(Vheap p') <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
- h <- hlookupE p'
- hupdateE p h
- return w
- _ -> return v -- return pointer to Hclos or Hconstr
- _ -> return v -- return Vimm or Vutuple
-evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
-evalExp globalEnv env (Dcon (_,c)) =
- do p <- hallocateE (Hconstr c [])
- return (Vheap p)
-
-evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
- where
- evalApp :: Venv -> Exp -> [Exp] -> Eval Value
- evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
- evalApp env (op @(Dcon (qdc@(m,c)))) es =
- do vs <- suspendExps globalEnv env es
- if isUtupleDc qdc then
- return (Vutuple vs)
- else
- {- allocate a thunk -}
- do p <- hallocateE (Hconstr c vs)
- return (Vheap p)
- evalApp env (op @ (Var(v@(_,p)))) es | isPrimVar v =
- do vs <- evalExps globalEnv env es
- case (p,vs) of
- ("raisezh",[exn]) -> raiseE exn
- ("catchzh",[body,handler,rws]) ->
- catchE (apply body [rws])
- (\exn -> apply handler [exn,rws])
- _ -> evalPrimop p vs
- evalApp env (External s _) es =
- do vs <- evalExps globalEnv env es
- evalExternal s vs
- evalApp env (Appt e _) es = evalApp env e es
- evalApp env (Lam (Tb _) e) es = evalApp env e es
- evalApp env (Cast e _) es = evalApp env e es
- evalApp env (Note _ e) es = evalApp env e es
- evalApp env e es =
- {- e must now evaluate to a closure -}
- do vs <- suspendExps globalEnv env es
- vop <- evalExp globalEnv env e
- apply vop vs
-
- apply :: Value -> [Value] -> Eval Value
- apply vop [] = return vop
- apply (Vheap p) (v:vs) =
- do Hclos env' x b <- hlookupE p
- v' <- evalExp globalEnv (eextend env' (x,v)) b
- apply v' vs
-
-
-evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
-evalExp globalEnv env (Lam (Vb(x,_)) e) =
- do p <- hallocateE (Hclos env' x e)
- return (Vheap p)
- where env' = thin env (delete x (freevarsExp e))
-evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
-evalExp globalEnv env (Let vdef e) =
- do env' <- evalVdef globalEnv env vdef
- evalExp globalEnv env' e
- where
- evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
- evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
- do v <- suspendExp globalEnv env e
- return (eextend env (x,v))
- evalVdef globalEnv env (Rec vdefs) =
- do vs0 <- mapM preallocate xs
- let env' = foldl eextend env (zip xs vs0)
- vs <- suspendExps globalEnv env' es
- mapM_ reallocate (zip vs0 vs)
- return env'
- where
- (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
- preallocate _ =
- do p <- hallocateE (Hconstr "UGH" [])
- return (Vheap p)
- reallocate (Vheap p0,Vheap p) =
- do h <- hlookupE p
- hupdateE p0 h
-
-evalExp globalEnv env (Case e (x,_) _ alts) =
- do z <- evalExp globalEnv env e
- let env' = eextend env (x,z)
- case z of
- Vheap p ->
- do h <- hlookupE p -- can fail due to black-holing
- case h of
- Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
- _ -> evalDefaultAlt env' alts
- Vutuple vs ->
- evalUtupleAlt env' vs (reverse alts)
- Vimm pv ->
- evalLitAlt env' pv (reverse alts)
- where
- evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
- evalDcAlt env dcon vs alts =
- f alts
- where
- f ((Acon (_,dcon') _ xs e):as) =
- if dcon == dcon' then
- evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
- else f as
- f [Adefault e] =
- evalExp globalEnv env e
- f _ = error "impossible Case-evalDcAlt"
-
- evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
- evalUtupleAlt env vs [Acon _ _ xs e] =
- evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
-
- evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
- evalLitAlt env pv alts =
- f alts
- where
- f ((Alit lit e):as) =
- let pv' = evalLit lit
- in if pv == pv' then
- evalExp globalEnv env e
- else f as
- f [Adefault e] =
- evalExp globalEnv env e
- f _ = error "impossible Case-evalLitAlt"
+evalExp globalEnv env = eval
+ where eval (Var qv) =
+ let v = qlookup globalEnv env qv
+ in case v of
+ Vheap p -> do
+ z <- hlookupE p -- can fail due to black-holing
+ case z of
+ Hthunk env' e -> do
+ hremoveE p -- black-hole
+ w <- evalExp globalEnv env' e -- result is guaranteed to be boxed!
+ case w of
+ Vheap p' -> do
+ h <- hlookupE p'
+ hupdateE p h
+ return w
+ _ -> error ("eval: w was not boxed: " ++ show w)
+ _ -> return v -- return pointer to Hclos or Hconstr
+ _ -> return v -- return Vimm or Vutuple
+ eval (Lit l) = return (Vimm (evalLit l))
+ eval (Dcon (_,c)) = do
+ p <- hallocateE (Hconstr c [])
+ return (Vheap p)
+ eval (App e1 e2) =
+ evalApp env e1 [e2]
+ where
+ evalApp :: Venv -> Exp -> [Exp] -> Eval Value
+ evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
+ evalApp env (Dcon (qdc@(_,c))) es =
+ do vs <- suspendExps globalEnv env es
+ if isUtupleDc qdc
+ then
+ return (Vutuple vs)
+ else
+ {- allocate a thunk -}
+ do p <- hallocateE (Hconstr c vs)
+ return (Vheap p)
+ evalApp env (Var(v@(_,p))) es | isPrimVar v =
+ do vs <- evalExps globalEnv env es
+ case (p,vs) of
+ ("raisezh",[exn]) -> raiseE exn
+ ("catchzh",[body,handler,rws]) ->
+ catchE (apply body [rws])
+ (\exn -> apply handler [exn,rws])
+ _ -> evalPrimop p vs
+ evalApp env (External s _) es =
+ do vs <- evalExps globalEnv env es
+ evalExternal s vs
+ evalApp env (Appt e _) es = evalApp env e es
+ evalApp env (Lam (Tb _) e) es = evalApp env e es
+ evalApp env (Cast e _) es = evalApp env e es
+ evalApp env (Note _ e) es = evalApp env e es
+ evalApp env e es =
+ {- e must now evaluate to a closure -}
+ do vs <- suspendExps globalEnv env es
+ vop <- evalExp globalEnv env e
+ apply vop vs
+
+ apply :: Value -> [Value] -> Eval Value
+ apply vop [] = return vop
+ apply (Vheap p) (v:vs) =
+ do Hclos env' x b <- hlookupE p
+ v' <- evalExp globalEnv (eextend env' (x,v)) b
+ apply v' vs
+ apply _ _ = error ("apply: operator is not a closure")
+
+ eval (Appt e _) = evalExp globalEnv env e
+ eval (Lam (Vb(x,_)) e) = do
+ p <- hallocateE (Hclos env' x e)
+ return (Vheap p)
+ where env' = thin env (delete x (freevarsExp e))
+ eval (Lam _ e) = evalExp globalEnv env e
+ eval (Let vdef e) =
+ do env' <- evalVdef globalEnv env vdef
+ evalExp globalEnv env' e
+ where
+ evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
+ evalVdef globalEnv env (Nonrec(Vdef((_,x),_,e))) =
+ do v <- suspendExp globalEnv env e
+ return (eextend env (x,v))
+ evalVdef globalEnv env (Rec vdefs) =
+ do vs0 <- mapM preallocate xs
+ let env' = foldl eextend env (zip xs (map Vheap vs0))
+ vs <- suspendExps globalEnv env' es
+ mapM_ reallocate (zip vs0 vs)
+ return env'
+ where
+ (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
+ preallocate _ =
+ do p <- hallocateE (Hconstr "UGH" [])
+ return p
+ reallocate (p0,Vheap p) =
+ do h <- hlookupE p
+ hupdateE p0 h
+ reallocate (_,_) = error "reallocate: expected a heap value"
+ eval (Case e (x,_) _ alts) =
+ do z <- evalExp globalEnv env e
+ let env' = eextend env (x,z)
+ case z of
+ Vheap p -> do
+ h <- hlookupE p -- can fail due to black-holing
+ case h of
+ Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
+ _ -> evalDefaultAlt env' alts
+ Vutuple vs ->
+ evalUtupleAlt env' vs (reverse alts)
+ Vimm pv ->
+ evalLitAlt env' pv (reverse alts)
+ where
+ evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
+ evalDcAlt env dcon vs = f
+ where
+ f ((Acon (_,dcon') _ xs e):as) =
+ if dcon == dcon' then
+ evalExp globalEnv
+ (foldl eextend env (zip (map fst xs) vs)) e
+ else f as
+ f [Adefault e] =
+ evalExp globalEnv env e
+ f _ = error $ "impossible Case-evalDcAlt"
+
+ evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
+ evalUtupleAlt env vs [Acon _ _ xs e] =
+ evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
+ evalUtupleAlt _ _ _ = error ("impossible Case: evalUtupleAlt")
+
+ evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
+ evalLitAlt env pv alts =
+ f alts
+ where
+ f ((Alit lit e):as) =
+ let pv' = evalLit lit
+ in if pv == pv' then
+ evalExp globalEnv env e
+ else f as
+ f [Adefault e] =
+ evalExp globalEnv env e
+ f _ = error "impossible Case-evalLitAlt"
- evalDefaultAlt :: Venv -> [Alt] -> Eval Value
- evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
+ evalDefaultAlt :: Venv -> [Alt] -> Eval Value
+ evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
+ evalDefaultAlt _ _ = error "evalDefaultAlt: impossible case"
-evalExp globalEnv env (Cast e _) = evalExp globalEnv env e
-evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
-evalExp globalEnv env (External s t) = evalExternal s []
+ eval (Cast e _) = evalExp globalEnv env e
+ eval (Note _ e) = evalExp globalEnv env e
+ eval (External s _) = evalExternal s []
evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
evalExps globalEnv env = mapM (evalExp globalEnv env)
suspendExp:: Menv -> Venv -> Exp -> Eval Value
suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
-suspendExp globalEnv env (Lit l) = return (Vimm (evalLit l))
-suspendExp globalEnv env (Lam (Vb(x,_)) e) =
+suspendExp _ _ (Lit l) = return (Vimm (evalLit l))
+suspendExp _ env (Lam (Vb(x,_)) e) =
do p <- hallocateE (Hclos env' x e)
return (Vheap p)
where env' = thin env (delete x (freevarsExp e))
suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
-suspendExp globalEnv env (External s _) = evalExternal s []
-suspendExp globalEnv env e =
+suspendExp _ _ (External s _) = evalExternal s []
+suspendExp _ env e =
do p <- hallocateE (Hthunk env' e)
return (Vheap p)
where env' = thin env (freevarsExp e)
Nothing -> error ("Interp: undefined module name: " ++ show m)
qlookup :: Menv -> Venv -> (Mname,Var) -> Value
-qlookup globalEnv env (m,k) =
+qlookup globalEnv env (m,k) =
case elookup (mlookup globalEnv env m) k of
Just v -> v
Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
evalPrimop :: Var -> [Value] -> Eval Value
-evalPrimop "zpzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1+i2)))
-evalPrimop "zmzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1-i2)))
-evalPrimop "ztzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1*i2)))
-evalPrimop "zgzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = mkBool (i1 > i2)
-evalPrimop "remIntzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1 `rem` i2)))
+evalPrimop "zpzh" = primIntBinop (+)
+evalPrimop "zpzhzh" = primDoubleBinop (+)
+evalPrimop "zmzh" = primIntBinop (-)
+evalPrimop "zmzhzh" = primDoubleBinop (-)
+evalPrimop "ztzh" = primIntBinop (*)
+evalPrimop "ztzhzh" = primDoubleBinop (*)
+evalPrimop "zgzh" = primIntCmpOp (>)
+evalPrimop "zlzh" = primIntCmpOp (<)
+evalPrimop "zlzhzh" = primDoubleCmpOp (<)
+evalPrimop "zezezh" = primIntCmpOp (==)
+evalPrimop "zlzezh" = primIntCmpOp (<=)
+evalPrimop "zlzezhzh" = primDoubleCmpOp (<=)
+evalPrimop "zgzezh" = primIntCmpOp (>=)
+evalPrimop "zszezh" = primIntCmpOp (/=)
+evalPrimop "zszhzh" = primDoubleCmpOp (/=)
+evalPrimop "negateIntzh" = primIntUnop (\ i -> -i)
+evalPrimop "quotIntzh" = primIntBinop quot
+evalPrimop "remIntzh" = primIntBinop rem
+evalPrimop "subIntCzh" = primSubIntC
+evalPrimop "mulIntMayOflozh" = primIntBinop
+ (\ i j ->
+ case (fromIntegral i, fromIntegral j) of
+ (I# x, I# y) ->
+ case x `mulIntMayOflo#` y of
+ k -> fromIntegral (I# k))
+evalPrimop "narrow32Intzh" = primIntUnop
+ (\ i ->
+ case fromIntegral i of
+ (I# j) -> case narrow32Int# j of
+ k -> fromIntegral (I# k))
+evalPrimop "int2Doublezh" = primInt2Double
+-- single-threaded, so, it's a no-op
+--evalPrimop "noDuplicatezh" [state] = return state
+evalPrimop "indexCharOffAddrzh" = primIndexChar
+evalPrimop "eqCharzh" = primCharCmpOp (==)
+evalPrimop "leCharzh" = primCharCmpOp (<)
+evalPrimop "ordzh" = primOrd
+evalPrimop "chrzh" = primChr
+evalPrimop "isSpacezh" = primCharUnop isSpace
+evalPrimop "isAlphazh" = primCharUnop isAlpha
+evalPrimop "hPutCharzh" = primHPutChar
-- etc.
-evalPrimop p vs = error ("undefined primop: " ++ p)
+evalPrimop p = error ("undefined primop: " ++ p)
+
+primIntUnop :: (Integer -> Integer) -> [Value] -> Eval Value
+primIntUnop op [Vimm (PIntzh i)] = return (Vimm (PIntzh (op i)))
+primIntUnop _ _ = error "primIntUnop: wrong number of arguments"
+
+primIntBinop :: (Integer -> Integer -> Integer) -> [Value] -> Eval Value
+primIntBinop op [Vimm (PIntzh i), Vimm (PIntzh j)] =
+ return (Vimm (PIntzh (i `op` j)))
+primIntBinop _ _ = error "primIntBinop: wrong number of arguments"
+
+primDoubleBinop :: (Rational -> Rational -> Rational) -> [Value] -> Eval Value
+primDoubleBinop op [Vimm (PDoublezh i), Vimm (PDoublezh j)] =
+ return (Vimm (PDoublezh (i `op` j)))
+primDoubleBinop _ _ = error "primDoubleBinop: wrong number of arguments"
+
+primIntCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
+primIntCmpOp op [Vimm (PIntzh i), Vimm (PIntzh j)] = mkBool (i `op` j)
+primIntCmpOp _ _ = error "primIntCmpOp: wrong number of arguments"
+
+primDoubleCmpOp :: (Rational -> Rational -> Bool) -> [Value] -> Eval Value
+primDoubleCmpOp op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = mkBool (i `op` j)
+primDoubleCmpOp _ _ = error "primDoubleCmpOp: wrong number of arguments"
+
+primCharCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
+primCharCmpOp op [Vimm (PCharzh c), Vimm (PCharzh d)] = mkBool (c `op` d)
+primCharCmpOp _ _ = error "primCharCmpOp: wrong number of arguments"
+
+primSubIntC :: [Value] -> Eval Value
+primSubIntC [Vimm (PIntzh i1), Vimm (PIntzh i2)] =
+ case (fromIntegral i1, fromIntegral i2) of
+ (I# int1, I# int2) ->
+ case (int1 `subIntC#` int2) of
+ (# res1, res2 #) ->
+ return $ Vutuple [Vimm (PIntzh (fromIntegral (I# res1))),
+ Vimm (PIntzh (fromIntegral (I# res2)))]
+primSubIntC _ = error "primSubIntC: wrong number of arguments"
+
+primInt2Double :: [Value] -> Eval Value
+primInt2Double [Vimm (PIntzh i)] =
+ return (Vimm (PDoublezh (fromIntegral i)))
+primInt2Double _ = error "primInt2Double: wrong number of arguments"
+
+primOrd :: [Value] -> Eval Value
+primOrd [Vimm (PCharzh c)] = return $ Vimm (PIntzh c)
+primOrd _ = error "primOrd: wrong number of arguments"
+
+primChr :: [Value] -> Eval Value
+primChr [Vimm (PIntzh c)] = return $ Vimm (PCharzh c)
+primChr _ = error "primChr: wrong number of arguments"
+
+primCharUnop :: (Char -> Bool) -> [Value] -> Eval Value
+primCharUnop op [Vimm (PCharzh c)] = mkBool (op (chr (fromIntegral c)))
+primCharUnop _ _ = error "primCharUnop: wrong number of arguments"
+
+primIndexChar :: [Value] -> Eval Value
+primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] =
+ -- String is supposed to be null-terminated, so if i == length(s),
+ -- we return null. (If i > length(s), emit nasal demons.)
+ return $ let len = fromIntegral $ length s in
+ if i < len
+ then Vimm (PCharzh (fromIntegral (ord (s !! fromIntegral i))))
+ else if i == len
+ then Vimm (PCharzh 0)
+ else error "indexCharOffAddr#: index too large"
+primIndexChar _ = error "primIndexChar: wrong number of arguments"
+
+primHPutChar :: [Value] -> Eval Value
+primHPutChar [Vimm (PIntzh hdl), Vimm (PCharzh c)] =
+ liftIO (hPutChar
+ (if hdl == 0
+ then stdin
+ else if hdl == 1
+ then stdout
+ else -- lol
+ stderr) (chr (fromIntegral c))) >>
+ returnUnit
+primHPutChar _ = error "primHPutChar: wrong number of arguments"
evalExternal :: String -> [Value] -> Eval Value
-- etc.
-evalExternal s vs = error "evalExternal undefined for now" -- etc.,etc.
-
+evalExternal s _ = error $ "evalExternal undefined for now: " ++ show s -- etc.,etc.
+
+returnUnit :: Eval Value
+returnUnit = do
+ p <- hallocateE (Hclos eempty "_"
+ (App (App (Dcon (dcUtuple 2)) stateToken) unitCon))
+ return $ Vheap p
+
evalLit :: Lit -> PrimValue
evalLit (Literal l t) =
case l of
Lrational r | (Tcon(_,"Floatzh")) <- t -> PFloatzh r
Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r
Lchar c | (Tcon(_,"Charzh")) <- t -> PCharzh (toEnum (ord c))
- Lstring s | (Tcon(_,"Addrzh")) <- t -> PAddrzh 0 -- should really be address of non-heap copy of C-format string s
+ Lstring s | (Tcon(_,"Addrzh")) <- t -> PString s
+ -- should really be address of non-heap copy of C-format string s
+ -- tjc: I am ignoring this comment
+ _ -> error ("evalLit: strange combination of literal "
+ ++ show l ++ " and type " ++ show t)
{- Utilities -}
+mkBool :: Bool -> Eval Value
mkBool True =
- do p <- hallocateE (Hconstr "ZdwTrue" [])
+ do p <- hallocateE (Hconstr "True" [])
return (Vheap p)
mkBool False =
- do p <- hallocateE (Hconstr "ZdwFalse" [])
+ do p <- hallocateE (Hconstr "False" [])
return (Vheap p)
-
+
+thin :: Ord a => Env a b -> [a] -> Env a b
thin env vars = efilter env (`elem` vars)
{- Return the free non-external variables in an expression. -}
freevarsExp :: Exp -> [Var]
freevarsExp (Var (Nothing,v)) = [v]
-freevarsExp (Var qv) = []
+freevarsExp (Var _) = []
freevarsExp (Dcon _) = []
freevarsExp (Lit _) = []
freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
-freevarsExp (Appt e t) = freevarsExp e
+freevarsExp (Appt e _) = freevarsExp e
freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
freevarsExp (Lam _ e) = freevarsExp e
freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
freevarsExp (Note _ e) = freevarsExp e
freevarsExp (External _ _) = []
+stateToken :: Exp
+stateToken = Var (qual primMname "realWorldzh")
-
-
+unitCon :: Exp
+unitCon = Dcon (qual baseMname "Z0T")
-all: Check.hs Core.hs Driver.hs Env.hs Interp.hs ParsecParser.hs ParseGlue.hs Prep.hs PrimCoercions.hs Prims.hs Printer.hs
+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
corePackageName :: Parser Pname
-- Package names can be lowercase or uppercase!
-corePackageName = identifier <|> upperName
+corePackageName = (identifier <|> upperName) >>= (return . P)
coreHierModuleNames :: Parser ([Id], Id)
coreHierModuleNames = do
Most are defined in PrimEnv, which is automatically generated from
GHC's primops.txt. -}
-module Prims(initialEnv, primEnv) where
+module Prims(initialEnv, primEnv, newPrimVars) where
import Core
+import Encoding
import Env
import Check
import PrimCoercions
++ ((snd tcArrow,ktArrow):primTcs)),
tsenv_=eempty,
cenv_=efromlist primDcs,
- venv_=efromlist (opsState ++ primVals)}
+ venv_=efromlist (newPrimVars ++ opsState ++ primVals)}
errorEnv :: Envs
errorEnv = Envs {tcenv_=eempty,
venv_=efromlist errorVals}
+newPrimVars :: [(Id, Ty)]
+newPrimVars = map (\ (v, ty) -> (zEncodeString v, ty))
+ [("hPutChar#", mkFunTy tIntzh (mkFunTy tCharzh tIOUnit)),
+ ("isSpace#", mkFunTy tCharzh tBool)]
+
+
primDcs :: [(Dcon,Ty)]
primDcs = map (\ ((_,c),t) -> (c,t))
[(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
forallAA = Tforall ("a",Kopen) (Tvar "a")
+tBool :: Ty
+tBool = Tcon (Just boolMname, "Bool")
tcChar :: Qual Tcon
tcChar = bv "Char"
tChar :: Ty
tList t = Tapp (Tcon tcList) t
tString :: Ty
tString = tList tChar
+tIntzh, tCharzh, tIOUnit :: Ty
+tIntzh = Tcon (primId "Int#")
+tCharzh = Tcon (primId "Char#")
+tIOUnit = Tapp (Tcon (Just (mkBaseMname "IOBase"), "IO"))
+ (Tcon (bv "Z0T"))
+
+primId :: String -> Qual Id
+primId = pv . zEncodeString
\ No newline at end of file
pmname Nothing = empty
pmname (Just m) = panmname m <> char '.'
-panmname (M (pkgName, parents, name)) =
+panmname (M (P pkgName, parents, name)) =
let parentStrs = map pname parents in
pname pkgName <> char ':' <>
-- This is to be sure to not print out:
A set of example programs for handling external core format.
In particular, typechecker and interpreter give a precise semantics.
-
-To build, run "make".
---------------------
-tjc April 2008:
+tjc April/May 2008:
==== Notes ====
3. When typechecking the ghc-prim:GHC.PrimopWrappers library module,
some declarations seem to have the wrong type signature (due to
confusion between (forall (t::*) ...) and (forall (t::?) ...).)
- This may be a GHC bug.
+ This is because the ? kind is not expressible in Haskell.
Typechecking all the GHC libraries eats about a gig of heap and takes a
long time. I blame Parsec. (Someone who was bored, or understood happy
better than I do, could update the old happy parser, which is still in the
repo.)
-The interpreter is not working yet.
+The interpreter is also memory-hungry, but works for small programs
+that only do simple I/O (e.g., putStrLn is okay; not much more than that)
+and don't use Doubles or arrays. For example: exp3_8, gen_regexps, queens,
+primes, rfib, tak, wheel-sieve1, and wheel-sieve2, if modified so as not
+to take input or arguments.
==== Building ====
--- /dev/null
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Replacement for GHC.Handle module
+
+module GHC_ExtCore.Handle(Handle(..), stdin, stderr, stdout, hFlush) where
+
+import GHC.Exts
+
+newtype Handle = H Int
+
+-- these shouldn't actually get used
+stdout, stdin, stderr :: Handle
+stdin = H 0
+stdout = H 1
+stderr = H 2
+
+-- ditto
+hFlush :: Handle -> IO ()
+hFlush _ = return ()
--- /dev/null
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Replacement for GHC.IO module
+
+module GHC_ExtCore.IO where
+
+import GHC.Exts
+import GHC_ExtCore.Handle
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr h s = mapM_ (hPutChar h) s
+
+hPutChar :: Handle -> Char -> IO ()
+hPutChar (H (I# i)) (C# c) = hPutChar# i c
+
+------------------------------------------------------------
+-- fake stubs for primops to fool GHC into typechecking this
+------------------------------------------------------------
+{-# NOINLINE hPutChar# #-}
+hPutChar# :: Int# -> Char# -> IO ()
+hPutChar# _ _ = return ()
--- /dev/null
+all: Handle.hs IO.hs Unicode.hs
+ ../../../../compiler/ghc-inplace -c -fext-core -package-name base-extcore Handle.hs IO.hs Unicode.hs -cpp -i../
+
+clean:
+ rm -f *.hcr *.hi *.o
--- /dev/null
+{-# OPTIONS -fglasgow-exts #-}
+
+-- Replacement for GHC.Unicode module
+
+{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -#include "WCsubst.h" #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Unicode
+-- Copyright : (c) The University of Glasgow, 2003
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC extensions)
+--
+-- Implementations for the character predicates (isLower, isUpper, etc.)
+-- and the conversions (toUpper, toLower). The implementation uses
+-- libunicode on Unix systems if that is available.
+--
+-----------------------------------------------------------------------------
+
+-- #hide
+module GHC_ExtCore.Unicode (
+ isAscii, isLatin1, isControl,
+ isAsciiUpper, isAsciiLower,
+ isPrint, isSpace, isUpper,
+ isLower, isAlpha, isDigit,
+ isOctDigit, isHexDigit, isAlphaNum,
+ toUpper, toLower, toTitle,
+ wgencat, isSpace#
+ ) where
+
+import GHC.Base
+import GHC.Real (fromIntegral)
+import GHC.Int
+import GHC.Word
+import GHC.Num (fromInteger)
+
+#include "HsBaseConfig.h"
+
+-- | Selects the first 128 characters of the Unicode character set,
+-- corresponding to the ASCII character set.
+isAscii :: Char -> Bool
+isAscii c = c < '\x80'
+
+-- | Selects the first 256 characters of the Unicode character set,
+-- corresponding to the ISO 8859-1 (Latin-1) character set.
+isLatin1 :: Char -> Bool
+isLatin1 c = c <= '\xff'
+
+-- | Selects ASCII lower-case letters,
+-- i.e. characters satisfying both 'isAscii' and 'isLower'.
+isAsciiLower :: Char -> Bool
+isAsciiLower c = c >= 'a' && c <= 'z'
+
+-- | Selects ASCII upper-case letters,
+-- i.e. characters satisfying both 'isAscii' and 'isUpper'.
+isAsciiUpper :: Char -> Bool
+isAsciiUpper c = c >= 'A' && c <= 'Z'
+
+-- | Selects control characters, which are the non-printing characters of
+-- the Latin-1 subset of Unicode.
+isControl :: Char -> Bool
+
+-- | Selects printable Unicode characters
+-- (letters, numbers, marks, punctuation, symbols and spaces).
+isPrint :: Char -> Bool
+
+{-
+-- | Selects white-space characters in the Latin-1 range.
+-- (In Unicode terms, this includes spaces and some control characters.)
+isSpace :: Char -> Bool
+-- isSpace includes non-breaking space
+-- Done with explicit equalities both for efficiency, and to avoid a tiresome
+-- recursion with GHC.List elem
+isSpace c = c == ' ' ||
+ c == '\t' ||
+ c == '\n' ||
+ c == '\r' ||
+ c == '\f' ||
+ c == '\v' ||
+ c == '\xa0' ||
+ iswspace (fromIntegral (ord c)) /= 0
+-}
+
+-- | Selects upper-case or title-case alphabetic Unicode characters (letters).
+-- Title case is used by a small number of letter ligatures like the
+-- single-character form of /Lj/.
+isUpper :: Char -> Bool
+
+-- | Selects lower-case alphabetic Unicode characters (letters).
+isLower :: Char -> Bool
+
+-- | Selects alphabetic Unicode characters (lower-case, upper-case and
+-- title-case letters, plus letters of caseless scripts and modifiers letters).
+-- This function is equivalent to 'Data.Char.isLetter'.
+isAlpha :: Char -> Bool
+
+-- | Selects alphabetic or numeric digit Unicode characters.
+--
+-- Note that numeric digits outside the ASCII range are selected by this
+-- function but not by 'isDigit'. Such digits may be part of identifiers
+-- but are not used by the printer and reader to represent numbers.
+isAlphaNum :: Char -> Bool
+
+-- | Selects ASCII digits, i.e. @\'0\'@..@\'9\'@.
+isDigit :: Char -> Bool
+isDigit c = c >= '0' && c <= '9'
+
+-- | Selects ASCII octal digits, i.e. @\'0\'@..@\'7\'@.
+isOctDigit :: Char -> Bool
+isOctDigit c = c >= '0' && c <= '7'
+
+-- | Selects ASCII hexadecimal digits,
+-- i.e. @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@.
+isHexDigit :: Char -> Bool
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
+ c >= 'a' && c <= 'f'
+
+-- | Convert a letter to the corresponding upper-case letter, if any.
+-- Any other character is returned unchanged.
+toUpper :: Char -> Char
+
+-- | Convert a letter to the corresponding lower-case letter, if any.
+-- Any other character is returned unchanged.
+toLower :: Char -> Char
+
+-- | Convert a letter to the corresponding title-case or upper-case
+-- letter, if any. (Title case differs from upper case only for a small
+-- number of ligature letters.)
+-- Any other character is returned unchanged.
+toTitle :: Char -> Char
+
+-- -----------------------------------------------------------------------------
+-- Implementation with the supplied auto-generated Unicode character properties
+-- table (default)
+
+#if 1
+
+-- Regardless of the O/S and Library, use the functions contained in WCsubst.c
+
+type CInt = HTYPE_INT
+
+isAlphaNum c = iswalnum (fromIntegral (ord c)) /= 0
+--isSpace c = iswspace (fromIntegral (ord c)) /= 0
+isControl c = iswcntrl (fromIntegral (ord c)) /= 0
+isPrint c = iswprint (fromIntegral (ord c)) /= 0
+isUpper c = iswupper (fromIntegral (ord c)) /= 0
+isLower c = iswlower (fromIntegral (ord c)) /= 0
+
+toLower c = chr (fromIntegral (towlower (fromIntegral (ord c))))
+toUpper c = chr (fromIntegral (towupper (fromIntegral (ord c))))
+toTitle c = chr (fromIntegral (towtitle (fromIntegral (ord c))))
+
+foreign import ccall unsafe "u_iswdigit"
+ iswdigit :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswalpha"
+ iswalpha :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswalnum"
+ iswalnum :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswcntrl"
+ iswcntrl :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswspace"
+ iswspace :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswprint"
+ iswprint :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswlower"
+ iswlower :: CInt -> CInt
+
+foreign import ccall unsafe "u_iswupper"
+ iswupper :: CInt -> CInt
+
+foreign import ccall unsafe "u_towlower"
+ towlower :: CInt -> CInt
+
+foreign import ccall unsafe "u_towupper"
+ towupper :: CInt -> CInt
+
+foreign import ccall unsafe "u_towtitle"
+ towtitle :: CInt -> CInt
+
+foreign import ccall unsafe "u_gencat"
+ wgencat :: CInt -> CInt
+
+-- -----------------------------------------------------------------------------
+-- No libunicode, so fall back to the ASCII-only implementation (never used, indeed)
+
+#else
+
+isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
+isPrint c = not (isControl c)
+
+-- The upper case ISO characters have the multiplication sign dumped
+-- randomly in the middle of the range. Go figure.
+isUpper c = c >= 'A' && c <= 'Z' ||
+ c >= '\xC0' && c <= '\xD6' ||
+ c >= '\xD8' && c <= '\xDE'
+-- The lower case ISO characters have the division sign dumped
+-- randomly in the middle of the range. Go figure.
+isLower c = c >= 'a' && c <= 'z' ||
+ c >= '\xDF' && c <= '\xF6' ||
+ c >= '\xF8' && c <= '\xFF'
+
+isAlpha c = isLower c || isUpper c
+isAlphaNum c = isAlpha c || isDigit c
+
+-- Case-changing operations
+
+toUpper c@(C# c#)
+ | isAsciiLower c = C# (chr# (ord# c# -# 32#))
+ | isAscii c = c
+ -- fall-through to the slower stuff.
+ | isLower c && c /= '\xDF' && c /= '\xFF'
+ = unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A')
+ | otherwise
+ = c
+
+
+toLower c@(C# c#)
+ | isAsciiUpper c = C# (chr# (ord# c# +# 32#))
+ | isAscii c = c
+ | isUpper c = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a')
+ | otherwise = c
+
+#endif
+
+-------------------------------------------------------------
+
+isSpace :: Char -> Bool
+isSpace (C# c) = isSpace# c
+
+isAlpha (C# c) = isAlpha# c
+
+------------------------------------------------------------
+-- fake stubs for primops to fool GHC into typechecking this
+------------------------------------------------------------
+{-# NOINLINE isSpace# #-}
+isSpace# :: Char# -> Bool
+isSpace# _ = True
+
+{-# NOINLINE isAlpha# #-}
+isAlpha# :: Char# -> Bool
+isAlpha# _ = False
+
projects / ghc-hetmet.git / commitdiff