From c287bea94592fffe63f85831ab651c28d64e4d6e Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Sat, 3 May 2008 23:10:44 +0000 Subject: [PATCH] Fix External Core interpreter 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. --- utils/ext-core/Check.hs | 2 +- utils/ext-core/Core.hs | 47 ++- utils/ext-core/Dependencies.hs | 222 +++++++++++ utils/ext-core/Driver.hs | 240 ++++-------- utils/ext-core/Interp.hs | 577 ++++++++++++++++++----------- utils/ext-core/Makefile | 5 +- utils/ext-core/ParsecParser.hs | 2 +- utils/ext-core/Prims.hs | 21 +- utils/ext-core/Printer.hs | 2 +- utils/ext-core/README | 12 +- utils/ext-core/lib/GHC_ExtCore/Handle.hs | 19 + utils/ext-core/lib/GHC_ExtCore/IO.hs | 21 ++ utils/ext-core/lib/GHC_ExtCore/Makefile | 5 + utils/ext-core/lib/GHC_ExtCore/Unicode.hs | 252 +++++++++++++ 14 files changed, 1032 insertions(+), 395 deletions(-) create mode 100644 utils/ext-core/Dependencies.hs create mode 100644 utils/ext-core/lib/GHC_ExtCore/Handle.hs create mode 100644 utils/ext-core/lib/GHC_ExtCore/IO.hs create mode 100644 utils/ext-core/lib/GHC_ExtCore/Makefile create mode 100644 utils/ext-core/lib/GHC_ExtCore/Unicode.hs diff --git a/utils/ext-core/Check.hs b/utils/ext-core/Check.hs index af3bb3c..4d35676 100644 --- a/utils/ext-core/Check.hs +++ b/utils/ext-core/Check.hs @@ -280,7 +280,7 @@ checkVdefg top_level (tcenv,tsenv,tvenv,cenv) (e_venv,l_venv) vdefg = do vdefIsMainWrapper :: AnMname -> Mname -> Bool vdefIsMainWrapper enclosing defining = - enclosing == mainMname && defining == wrapperMainMname + enclosing == mainMname && defining == wrapperMainAnMname checkExpr :: AnMname -> Menv -> [Tdef] -> Venv -> Tvenv -> Exp -> Ty diff --git a/utils/ext-core/Core.hs b/utils/ext-core/Core.hs index 0fb48b8..9df300e 100644 --- a/utils/ext-core/Core.hs +++ b/utils/ext-core/Core.hs @@ -2,10 +2,12 @@ module Core where import Encoding +import Data.Generics import List (elemIndex) data Module = Module AnMname [Tdef] [Vdefg] + deriving (Data, Typeable) data Tdef = Data (Qual Tcon) [Tbind] [Cdef] @@ -14,15 +16,19 @@ data Tdef -- 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) @@ -36,15 +42,18 @@ data Exp | 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) @@ -64,6 +73,7 @@ data Ty | InstCoercion Ty Ty | LeftCoercion Ty | RightCoercion Ty + deriving (Data, Typeable) data Kind = Klifted @@ -71,6 +81,7 @@ data Kind | 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. @@ -92,13 +103,13 @@ data CoercionKind = 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) @@ -111,8 +122,9 @@ data CoreLit = Lint Integer 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 @@ -126,6 +138,9 @@ qual mn t = (Just mn, t) unqual :: t -> Qual t unqual = (,) Nothing +getModule :: Qual t -> Mname +getModule = fst + type Id = String eqKind :: Kind -> Kind -> Bool @@ -184,16 +199,23 @@ errMname = mkBaseMname "Err" 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") @@ -201,6 +223,9 @@ 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) @@ -243,4 +268,8 @@ dcUtupleTy n = 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 [] = [] diff --git a/utils/ext-core/Dependencies.hs b/utils/ext-core/Dependencies.hs new file mode 100644 index 0000000..578ecf3 --- /dev/null +++ b/utils/ext-core/Dependencies.hs @@ -0,0 +1,222 @@ +{-# 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" diff --git a/utils/ext-core/Driver.hs b/utils/ext-core/Driver.hs index 684f31f..57d688e 100644 --- a/utils/ext-core/Driver.hs +++ b/utils/ext-core/Driver.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -Wall #-} + {- A simple driver that loads, typechecks, prepares, re-typechecks, and interprets the GHC standard Prelude modules and an application module called Main. @@ -6,7 +8,6 @@ import Control.Exception import Data.List -import Maybe import Monad import Prelude hiding (catch) import System.Cmd @@ -15,27 +16,28 @@ import System.Exit 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 @@ -43,168 +45,76 @@ validateResults origFile genFile = do _ -> "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 diff --git a/utils/ext-core/Interp.hs b/utils/ext-core/Interp.hs index e730012..3f07922 100644 --- a/utils/ext-core/Interp.hs +++ b/utils/ext-core/Interp.hs @@ -1,4 +1,4 @@ -{-# 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 @@ -17,13 +17,17 @@ Just a sampling of primitive types and operators are included. 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!) @@ -39,6 +43,10 @@ data Value = | 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 @@ -49,6 +57,7 @@ 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 @@ -92,56 +101,66 @@ hempty = Heap 0 eempty 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: @@ -171,12 +190,12 @@ In evalExp: 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 @@ -185,179 +204,190 @@ evalModule globalEnv (Module mn tdefs vdefgs) = 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)) @@ -365,8 +395,8 @@ suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env 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) @@ -382,24 +412,143 @@ mlookup globalEnv _ (Just m) = 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 @@ -410,28 +559,34 @@ evalLit (Literal l t) = 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 @@ -447,6 +602,8 @@ freevarsExp (Cast e _) = freevarsExp e freevarsExp (Note _ e) = freevarsExp e freevarsExp (External _ _) = [] +stateToken :: Exp +stateToken = Var (qual primMname "realWorldzh") - - +unitCon :: Exp +unitCon = Dcon (qual baseMname "Z0T") diff --git a/utils/ext-core/Makefile b/utils/ext-core/Makefile index 7015105..c26523a 100644 --- a/utils/ext-core/Makefile +++ b/utils/ext-core/Makefile @@ -1,6 +1,9 @@ -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 diff --git a/utils/ext-core/ParsecParser.hs b/utils/ext-core/ParsecParser.hs index 4afa924..9acb138 100644 --- a/utils/ext-core/ParsecParser.hs +++ b/utils/ext-core/ParsecParser.hs @@ -36,7 +36,7 @@ coreModuleName = do corePackageName :: Parser Pname -- Package names can be lowercase or uppercase! -corePackageName = identifier <|> upperName +corePackageName = (identifier <|> upperName) >>= (return . P) coreHierModuleNames :: Parser ([Id], Id) coreHierModuleNames = do diff --git a/utils/ext-core/Prims.hs b/utils/ext-core/Prims.hs index d061200..43c687c 100644 --- a/utils/ext-core/Prims.hs +++ b/utils/ext-core/Prims.hs @@ -4,9 +4,10 @@ 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 @@ -30,7 +31,7 @@ primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) $ ++ ((snd tcArrow,ktArrow):primTcs)), tsenv_=eempty, cenv_=efromlist primDcs, - venv_=efromlist (opsState ++ primVals)} + venv_=efromlist (newPrimVars ++ opsState ++ primVals)} errorEnv :: Envs errorEnv = Envs {tcenv_=eempty, @@ -39,6 +40,12 @@ 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]] @@ -95,6 +102,8 @@ str2A, forallAA :: Ty 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 @@ -105,3 +114,11 @@ tList :: Ty -> 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 diff --git a/utils/ext-core/Printer.hs b/utils/ext-core/Printer.hs index 4e42445..0ae4b18 100644 --- a/utils/ext-core/Printer.hs +++ b/utils/ext-core/Printer.hs @@ -85,7 +85,7 @@ pqname (m,v) = pmname m <> pname v 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: diff --git a/utils/ext-core/README b/utils/ext-core/README index 4fb16ff..6091935 100644 --- a/utils/ext-core/README +++ b/utils/ext-core/README @@ -1,10 +1,8 @@ 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 ==== @@ -21,14 +19,18 @@ The checker should work on most programs. Bugs I'm aware of: 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 ==== diff --git a/utils/ext-core/lib/GHC_ExtCore/Handle.hs b/utils/ext-core/lib/GHC_ExtCore/Handle.hs new file mode 100644 index 0000000..6417c28 --- /dev/null +++ b/utils/ext-core/lib/GHC_ExtCore/Handle.hs @@ -0,0 +1,19 @@ +{-# 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 () diff --git a/utils/ext-core/lib/GHC_ExtCore/IO.hs b/utils/ext-core/lib/GHC_ExtCore/IO.hs new file mode 100644 index 0000000..81d9226 --- /dev/null +++ b/utils/ext-core/lib/GHC_ExtCore/IO.hs @@ -0,0 +1,21 @@ +{-# 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 () diff --git a/utils/ext-core/lib/GHC_ExtCore/Makefile b/utils/ext-core/lib/GHC_ExtCore/Makefile new file mode 100644 index 0000000..5cf65c0 --- /dev/null +++ b/utils/ext-core/lib/GHC_ExtCore/Makefile @@ -0,0 +1,5 @@ +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 diff --git a/utils/ext-core/lib/GHC_ExtCore/Unicode.hs b/utils/ext-core/lib/GHC_ExtCore/Unicode.hs new file mode 100644 index 0000000..84c88d4 --- /dev/null +++ b/utils/ext-core/lib/GHC_ExtCore/Unicode.hs @@ -0,0 +1,252 @@ +{-# 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 + -- 1.7.10.4